diff --git a/Tequila/Client.pm b/Tequila/Client.pm
index 56c1fec..b79586b 100644
--- a/Tequila/Client.pm
+++ b/Tequila/Client.pm
@@ -1,1254 +1,1255 @@
 #!/usr/bin/perl
 #
 ##############################################################################
 #
 # File Name:    Tequila/Client.pm
 # Description:  Encapsule l'authentification Tequila pour les CGI en perl
 # Author:       Claude Lecommandeur (Claude.Lecommandeur@epfl.ch)
 # Date Created: Thu Oct 31 09:16:06 CET 2002
 #
 # 2.0.1 -> 2.0.2
 #   - Remove all remnant of opaque ans urlauth.
 #   - Fix localorg image access. Now, it is logo.gif.
 #
 # 2.0.2 -> 2.0.3
 #   - In loadargs : protect from multiple 'key' values.
 #   - Remove all remnant of 'fromserver'.
 #   - Fetch images from server.
 #
 # 2.0.2 -> 2.0.3
 #   - Fix for ever the key business. Now there is a separateket for the request
 #     and session.
 #   - No longer use the key= attribute in the urlaccess, always use cookies.
 #
 # 2.0.3 -> 2.0.4
 #   - Check session key validity (/^[a-z0-9]+$/).
 #
 # 2.0.4  -> 2.0.5
 #   - REALLY Check session key validity.
 #   - Improve search of sessions directory.
 #
 # 2.0.5  -> 2.0.6
 #   - Improve random initialization.
 #   - Fix bug in key calculation that never uses '9'.
 #
 #
 ##############################################################################
 #
 package Tequila::Client;
 #
 use strict;
 use Socket;
 use IO::Socket::SSL;
 use IO::Socket::INET;
 
 use vars qw(@ISA $VERSION $XS_VERSION $CONFIG $DEBUG);
 
 my ($defaultserver, $defaultserverurl, $defaultsessionsdir);
 
 $VERSION = '2.0.6';
 
 sub new { # Exported
   my $class = shift;
   my  %args = @_;
 
   staticinit ();
   my  $self = {
             partner => undef,
            resource => undef,
            urlacces => undef,
           urlaccess => undef,
              usessl => 1,
             service => undef,
             request => undef,
                wish => undef,
             require => undef,
           wantright => undef,
            wantrole => undef,
            language => 'english',
          identities => undef,
         localserver => $defaultserver,
           serverurl => $defaultserverurl,
          serverfile => "/tequila",
         usesessions => 1,
         sessionsdir => $defaultsessionsdir,
     sessionsmanager => undef,
          sessionmax => 24 * 3600,
   checkcertificates => 0,
              cafile => undef,
          clientargs => {},
              allows => undef,
        authstrength => 0,
           hascookie => 0,
          usecookies => 1,
          cookiename => undef,
        cookiepolicy => 'session',
       servercookies => 1,
        allsensitive => undef,
            username => undef,
             contact => undef,
             testing => undef,
               debug => undef,
           logouturl => undef,
 
             verbose => 0,
       authenticated => undef,
         initialized => undef,
         querystring => undef,
            pathinfo => undef,
          scriptname => undef,
          servername => undef,
          serverport => undef,
               https => undef,
          sessionkey => undef,
          requestkey => undef,
                 org => undef,
                user => undef,
                host => undef,
                vars => undef,
               attrs => undef,
             appargs => undef,
   };
   foreach my $arg (keys %args) {
     if (ref ($args {$arg}) eq 'ARRAY') {
       $self->{$arg} = join ('+', @{$args {$arg}});
       next;
     }
     $self->{$arg} = $args {$arg};
   }
   $self->{urlaccess} ||= $self->{urlacces};
   bless $self, $class;
   #$self->init (); # Too dangerous.
   return $self;
 }
 
 sub init {
   my $self = shift;
   return if $self->{initialized};
   my $appargs = loadargs ();
 
   $self->{querystring} = $ENV {QUERY_STRING};
   $self->{pathinfo}    = $ENV {PATH_INFO};
   $self->{scriptname}  = $ENV {SCRIPT_NAME};
   $self->{servername}  = $ENV {SERVER_NAME};
   $self->{serverport}  = $ENV {SERVER_PORT};
   $self->{https}       = $ENV {HTTPS};
   $self->{appargs}     = $appargs;
 
   if ($self->{usecookies}) {
     $self->{sessioncookiename} ||= $self->{cookiename};
     unless ($self->{sessioncookiename}) {
       my $scriptname = $self->{scriptname};
       if ($scriptname =~ /^.*\/(\S+)$/) {
         $self->{sessioncookiename} = "Tequila_$1";
       } else {
         $self->{sessioncookiename} = 'teqsession_key';
       }
     }
     unless ($self->{requestcookiename}) {
       my $scriptname = $self->{scriptname};
       if ($scriptname =~ /^.*\/(\S+)$/) {
         $self->{requestcookiename} = "Tequila_req_$1";
       } else {
         $self->{requestcookiename} = 'teqrequest_key';
       }
     }
     my $sessioncookiename = $self->{sessioncookiename};
     my $requestcookiename = $self->{requestcookiename};
     my $allcookies = $ENV {HTTP_COOKIE};
     foreach my $cookie (split (/; /, $allcookies)) {
       if ($cookie =~ /^\Q$sessioncookiename\E=(.*)$/) {
         $self->{sessionkey} = $1;
         $self->{hascookie}  = 1;
         last;
       }
       if ($cookie =~ /^\Q$requestcookiename\E=(.*)$/) {
         $self->{requestkey} = $1;
         last;
       }
     }
   } else {
     $self->{sessionkey} ||= $appargs->{tequila_key} || $appargs->{key};
     delete $appargs->{tequila_key};
     delete $appargs->{key};
   }
   $self->{initialized} = 1;
 }
 
 sub authenticate {
   my $self = shift;
   return if $self->{authenticated};
   init ($self) unless $self->{initialized};
   if ($self->authenticated ()) {
     $self->{attrs}->{authstrength} ||= 0;
     if ($self->{attrs}->{authstrength} >= $self->{authstrength}) {
       return;
     }
   }
   $self->{requestkey} = $self->createserverrequest ();
   $self->redirecttoserver ();
 }
 
 sub authenticated {
   my $self = shift;
   return 1 if $self->{authenticated};
   init ($self) unless $self->{initialized};
 
   if ($self->{sessionkey}) {
     if ($self->{usesessions} && ($self->loadsession () == 1)) {
       if ($self->checkuserprofile ()) {
         $self->depositcookie ($self->{sessioncookiename}, $self->{sessionkey})
           if (!$self->{hascookie} && $self->{usecookies});
         $self->{authenticated} = 1;
       } else { return; }
     } else { return; }
   }
   elsif ($self->{requestkey}) {
     $self->removecookie ($self->{requestcookiename});
     if ($self->fetchattributes ()) {
       $self->depositcookie ($self->{sessioncookiename}, $self->{sessionkey})
         if $self->{usecookies};
       $self->{authenticated} = 1;
     } else { return; }
   }
   return $self->{authenticated};
 }
 
 sub logout {
   my $self = shift;
   $self->killsession () if $self->{usesessions};
   $self->{authenticated} = 0;
   $self->removecookie ($self->{sessioncookiename});
 }
 
 sub globallogout {
   my $self = shift;
   $self->logout ();
   my        $pi = $self->{pathinfo};
   my        $me = $self->{scriptname};
   my        $us = $self->{servername};
   my $serverurl = $self->{serverurl};
   my $logouturl = $self->{logouturl} || $self->{urlaccess} || "http://$us$me$pi";
   $logouturl    = escapeurl ($logouturl);
   print qq{Location: $serverurl/logout?urlaccess=$logouturl\r\n\r\n};
 }
 
 sub redirecttoserver {
   my $self = shift;
   my $requestkey = $self->{requestkey};
   $self->error ("Internal error in redirecttoserver : requestkey undefined.")
     unless $requestkey;
   $self->removecookie  ($self->{sessioncookiename});
   $self->depositcookie ($self->{requestcookiename}, $self->{requestkey});
   print qq{WWW-Authenticate: Tequila serverurl="$self->{serverurl}" requestkey="$requestkey"\r\n};
   print qq{Location: $self->{serverurl}/auth?requestkey=$requestkey\r\n\r\n};
   exit;
 }
 
 sub loadsessionsmanager {
   my $self = shift;
   my $sessionsmanager = $self->{sessionsmanager};
   my $SM = 'Tequila::' . $sessionsmanager;
   eval "use $SM; 1;" || do {
     warn "loadsessionsmanager ($sessionsmanager) failed1.\n" if $self->{verbose};
     $self->error ("loadsessionsmanager : Unable to load session manager $SM : $@");
   };
   my $sm;
   eval "\$sm = new $SM (dsmhost => 'localhost', dsmport => 2345);" || do {
     warn "loadsessionsmanager ($sessionsmanager) failed2.\n" if $self->{verbose};
     $self->error ("loadsessionsmanager : Unable to initialized session manager $SM : $@");
   };
   $self->{sm} = $sm;
   warn "loadsessionsmanager ($sessionsmanager) OK.\n" if $self->{verbose};
 }
 
 sub createsession {
   my $self = shift;
   checksessionkey ($self, $self->{sessionkey});
   warn "createsession ($self->{sessionsdir}:$self->{sessionkey}:$self->{org}".
        ":$self->{user}:$self->{host})" if $self->{verbose};
   
   if ($self->{sessionsmanager}) {
     $self->loadsessionsmanager () unless $self->{sm};
     my $sm = $self->{sm};
     return unless $sm;
     my $session = {
           org => $self->{org},
          user => $self->{user},
          host => $self->{host},
       timeout => $self->{sessionmax}
     };
     foreach my $attr (keys %{$self->{attrs}}) {
       my $value = $self->{attrs}->{$attr};
       $value =~ s/\n/\\n/g;
       $value =~ s/\r]//g;
       $session->{$attr} = $value;
     }
     my $status = $sm->createsession ("Application:$self->{sessionkey}", $session);
     unless ($status) {
       $self->error ("createsession : Unable to create session Application:$self->{sessionkey}");
     }
     warn "createsession : session $self->{sessionkey} created\n" if $self->{verbose};
     return 1;
   } else {
     return $self->createfilesession ();
   }
 }
 
 sub createfilesession {
   my $self = shift;
   warn "createfilesession ($self->{sessionsdir}:$self->{sessionkey}:$self->{org}".
        ":$self->{user}:$self->{host})" if $self->{verbose};
   
   checksessionkey ($self, $self->{sessionkey});
   my $sesdir = $self->{sessionsdir};
   unless (-d $sesdir && -w $sesdir) {
     $self->error ("Tequila:createsession: Session directory $sesdir doesn't ".
                   "exist or not writable.");
   }
   unless (open (SESSION, ">$sesdir/$self->{sessionkey}")) {
     $self->error ("Tequila:createsession: Unable to open session file ".
                   "($sesdir/$self->{sessionkey}) : $!");
   }
   print SESSION
     "org=$self->{org}\n",
     "user=$self->{user}\n",
     "host=$self->{host}\n"
     ;
   foreach my $attr (keys %{$self->{attrs}}) {
     my $value = $self->{attrs}->{$attr};
     $value = "\\\n" . $value . "\n" if ($value =~ /[\n\r]/);
     print SESSION "$attr=$value\n";
   }
   close (SESSION);
   return 1;
 }
 
 #
 # loadsession
 #
 # returns : 1 : OK.
 #           2 : pas de session.
-#           3 : session échue.
+#           3 : session échue.
 #           4 : pas la bonne machine au bout
 #
 sub loadsession {
   my $self = shift;
   return 2 unless $self->{sessionkey};
   checksessionkey ($self, $self->{sessionkey});
 
   if ($self->{sessionsmanager}) {
     $self->loadsessionsmanager () unless $self->{sm};
     my $sm = $self->{sm};
     return unless $sm;
     warn "loadsession ($self->{sessionkey} OK\n" if $self->{verbose};
     my $session = $sm->readsession ("Application:$self->{sessionkey}");
     return 2 unless $session;
     foreach my $attr (keys %$session) {
       $self->{$attr} = $session->{$attr};
     }
     return 1;
   } else {
     return $self->loadfilesession ();
   }
 }
 
 sub loadfilesession {
   my       $self = shift;
   my $sessionkey = $self->{sessionkey};
   my     $sesdir = $self->{sessionsdir};
   my     $sesmax = $self->{sessionmax};
 
   return 2 unless $self->{sessionkey};
   checksessionkey ($self, $self->{sessionkey});
 
   my $keyfile = "$sesdir/$sessionkey";
   return 2 unless (-r $keyfile);
   my $lastaccess = (stat ($keyfile))[8];
   my        $now = time;
   if ($lastaccess < ($now - $sesmax)) {
     unlink ($keyfile);
     return 3;
   }
   open (SESSION, $keyfile) || return 2;
   while (<SESSION>) {
     chomp;
     my ($attr, $value) = split (/=/, $_, 2);
     if ($attr =~ /^(org|user|host)$/) {
       $self->{$attr} = $value;
       next;
     }
     if ($value =~ /^\\/) {
       $value = "\\\n";
       while (<SESSION>) {
         last if /^[\r\n]*$/;
         $value .= $_;
       }
     }
     $self->{attrs}->{$attr} = $value;
   }
   close (SESSION);
   utime ($now, $now, "$sesdir/$sessionkey");
   killsession ($self) unless $self->{usesessions};
   return 1;
 }
 
 sub checkuserprofile {
   my      $self = shift;
   my     $abort = shift;
   my   $require = $self->{require};
   my  $resource = $self->{resource};
   my $wantright = $self->{wantright};
   my  $wantrole = $self->{wantrole};
 
   return 1 if ($self->{attrs}->{status} eq 'fail'); # Don't check failed login.
   if ($resource && ($resource ne $self->{attrs}->{resource})) {
     return 0 if !$abort;
     $self->error (
       "Tequila:checkuserprofile: request found on the server, doesnt match the".
       " requested resource :".
       "<br>server says resource = $self->{attrs}->{resource},".
       "<br>client says resource = $resource");
   }
   if ($require && ($require ne $self->{attrs}->{require})) {
     return 0 if !$abort;
     $self->error (
       "Tequila:checkuserprofile: request found on the server, doesnt fit the".
       " required filter :".
       "<br>server says require = $self->{attrs}->{require},".
       "<br>client says require = $require");
   }
   if ($wantright) {
     my @rights = split (/,/, $wantright);
     foreach my $right (@rights) {
       unless ($self->{attrs}->{$right}) {
         return 0 if !$abort;
         $self->error (
           "Tequila:checkuserprofile: request found on the server, doesnt fit the".
           " required filter : right $right is missing");
       }
     }
   }
   if ($wantrole) {
     my @roles = split (/,/, $wantrole);
     foreach my $role (@roles) {
       unless ($self->{attrs}->{$role}) {
         return 0 if !$abort;
         $self->error (
           "Tequila:checkuserprofile: request found on the server, doesnt fit the".
           " required filter : role $role is missing");
       }
     }
   }
   return 1;
 }
 
 sub purgesessions {
   my $self = shift;
   return if $self->{sessionsmanager};
   my $sesmax = $self->{sessionmax};
   opendir (SESSIONS, $self->{sessionsdir}) || return;
   my @sessions = readdir (SESSIONS);
   closedir (SESSIONS);
   @sessions = grep (!/^\.\.?$/, @sessions);
   foreach my $session (@sessions) {
     my $sessionfile = "$self->{sessionsdir}/$session";
     next if -d $sessionfile;
     my $lastaccess = (stat ($sessionfile))[8];
     my        $now = time;
     unlink ($sessionfile) if ($lastaccess < ($now - $sesmax));
   }
 }
 
 sub killsession {
   my $self = shift;
   checksessionkey ($self, $self->{sessionkey});
   if ($self->{sessionsmanager}) {
     $self->loadsessionsmanager () unless $self->{sm};
     my $sm = $self->{sm};
     return unless $sm;
     $sm->deletesession ("Application:$self->{sessionkey}");
   } else {
     my $sessionfile = "$self->{sessionsdir}/$self->{sessionkey}";
     unlink ($sessionfile) || "killsession: Unable to kill session $self->{sessionkey} : $!";
   }
 }
 
 sub request {
   my $self = shift;
   $self->{request} = join ('+', @_);
 }
 
 sub wish {
   my $self = shift;
   $self->{wish} = join ('+', @_);
 }
 
 sub require {
   my   $self = shift;
   my $newreq = shift;
   if ($self->{require}) {
     $self->{require} = "($self->{require})&($newreq)";
   } else {
     $self->{require} = $newreq;
   }
 }
 
 sub authstrength {
   my $self = shift;
   $self->{authstrength} = shift;
 }
 
 sub checkcerts {
   my $self = shift;
   $self->{checkcertificates} = shift;
 }
 
 sub cafile {
   my $self = shift;
   $self->{cafile} = shift;
 }
 
 sub wantright {
   my $self = shift;
   $self->{wantright} = shift;
 }
 
 sub wantrole {
   my $self = shift;
   $self->{wantrole} = shift;
 }
 
 sub setresource {
   my $self = shift;
   $self->{resource} = shift;
 }
 
 sub setpartner {
   my $self = shift;
   $self->{partner} = shift;
 }
 
 sub setlang {
   my $self = shift;
   $self->{language} = shift;
 }
 
 sub setidentities {
   my $self = shift;
   $self->{identities} = shift;
 }
 
 sub allsensitive {
   my $self = shift;
   my $value = shift;
   $self->{allsensitive} = $value ? 1 : 0;
 }
 
 sub usecookies {
   my $self = shift;
   my $value = shift;
   $self->{usecookies} = $value ? 1 : 0;
 }
 
 sub setcookiename {
   my $self = shift;
   $self->{cookiename} = $self->{sessioncookiename} = shift;
 }
 
 sub setcookiepolicy {
   my $self = shift;
   $self->{cookiepolicy} = shift;
 }
 
 sub useloginwindow {
   # nothing.
 }
 
 sub servercookies {
   my $self = shift;
   $self->{servercookies} = shift;
 }
 
 sub setopaque {
   # nothing
 }
 
 sub setserver {
   my   $self = shift;
   my $server = shift;
   $self->{localserver} = $server;
 
   my $binaddr = gethostbyname ($server);
   my $srvaddr = join ('.', unpack ('C4', $binaddr));
   $self->{sessionsdir} = $self->{sessionsdir} . '/' . $srvaddr;
   $self->{serverurl}   = "https://$self->{localserver}/tequila";
 }
 
 sub setserverurl {
   my      $self = shift;
   my $serverurl = shift;
 
   $self->{serverurl} = $serverurl;
   if ($serverurl =~ m!^(http|https)://([^/]*)(.*)$!) {
     my ($host, $file) = ($2, $3);
     $host = $1 if $host =~ /^([^:]*):(.*)$/;
     $self->{localserver} = $host;
     $self->{serverfile}  = $file;
   }
   my $binaddr = gethostbyname ($self->{localserver});
   my $srvaddr = join ('.', unpack ('C4', $binaddr));
   $self->{sessionsdir} = $self->{sessionsdir} . '/' . $srvaddr;
 }
 
 sub getserverurl {
   my $self = shift;
   return $self->{serverurl};
 }
 
 sub setlogouturl {
   my $self = shift;
   $self->{logouturl} = shift;
 }
 
 sub usessl {
   my $self = shift;
   $self->{usessl} = shift;
 }
 
 sub allows {
   my ($self, $allow) = @_;
   $self->{allows} .= '&' if $self->{allows};
   $self->{allows} .= $allow;
 }
 
 sub setusername {
   my $self = shift;
   $self->{username} = shift;
 }
 
 sub setorg {
   my $self = shift;
   $self->{org} = shift;
 }
 
 sub setservice {
   my $self = shift;
   $self->{service} = shift;
 }
 
 sub setclientarg {
   my ($self, $key, $value) = @_;
   $self->{clientargs}->{$key} = $value;
 }
 
 sub getclientarg {
   my ($self, $key) = @_;
   return $self->{clientargs}->{$key};
 }
 
 sub usesessions {
   my $self = shift;
   $self->{usesessions} = shift;
 }
 
 sub setsessionsdir {
   my $self = shift;
   $self->{sessionsdir} = shift;
 }
 
 sub getsessionsdir {
   my $self = shift;
   return $self->{sessionsdir};
 }
 
 sub setsessionsduration {
   my $self = shift;
   $self->{sessionmax} = shift;
 }
 
 sub getsessionsduration {
   my $self = shift;
   return $self->{sessionmax};
 }
 
 sub loadargs {
   my  $clen = $ENV {CONTENT_LENGTH};
   my  $meth = $ENV {REQUEST_METHOD};
   my   $get = $ENV {QUERY_STRING};
 
   my $args;
   my $post = '';
   if ($meth eq 'POST') {
     read STDIN, $post, $clen;
     my $ctype = $ENV {CONTENT_TYPE};
     if ($ctype =~ /^multipart\/form-data;\s+boundary=(.*)$/) {
       my $boundary = $1;
       my @parts = split (/$boundary/, $post);
       shift @parts; pop @parts;
 
       my $pat1 = qq{\r\nContent-Disposition: form-data; name="(.*?)"};
       my $pat2 = qq{\r\nContent-Type: (.*?)\r\n\r\n(.*)};
       foreach my $part (@parts) {
         if($part =~ /^$pat1\r\n\r\n(.*)\r\n/is) {
           my  $name = $1;
           my $value = $2;
           $args->{$name} = $value;
           next;
         }
         if ($part =~ /^$pat1; filename="(.*?)"$pat2\r\n/is) {
           my     $name = $1;
           my $filename = $2; $filename =~ s/.*\\//; $filename =~ s/.*\///;
           my    $ctype = $3;
           my  $content = $4; $content =~ s/!$//;
           $args->{$name} = {
                filename => $filename,
             contenttype => $ctype,
                 content => $content,
           };
           next;
         }
         if ($part =~ /^$pat1; filename="(.*?)"\r\n(.*)\r\n/is) {
           my     $name = $1;
           my $filename = $2; $filename =~ s/.*\\//; $filename =~ s/.*\///;
           my  $content = $3; $content =~ s/!$//;
           $args->{$name} = {
                filename => $filename,
             contenttype => "unknown",
                 content => $content,
           };
           next;
         }
       }
       $post = '';
     }
   }
   my $all = $get . '&' . $post;
   my @fields = split (/&/, $all);
   foreach (@fields) {
     s/\+/ /g;
     s/%([0-9a-f]{2,2})/pack ("C", hex ($1))/gie;
   }
   foreach my $field (@fields) {
     next unless ($field =~ /=/);
     my ($key, $value) = split(/=/, $field, 2);
     next unless $value;
     if ($key eq 'key') {
       $args->{$key} = $value;
     } else {
       my $oldval = $args->{$key};
       $args->{$key} = $oldval ? "$oldval,$value" : $value;
     }
   }
   return $args;
 }
 
 sub parseargs {
   my $qstr = shift;
   return unless $qstr;
 
   my $args;
   my @fields = split (/&/, $qstr);
   foreach (@fields) {
     s/\+/ /g;
     s/%([0-9a-f]{2,2})/pack ("C", hex ($1))/gie;
   }
   foreach my $field (@fields) {
     next unless ($field =~ /=/);
     my ($key, $value) = split (/=/, $field, 2);
     my $oldval = $args->{$key};
     $args->{$key} = $oldval ? "$oldval,$value" : $value;
   }
   return $args;
 }
 
 sub head {
   my $title = shift || 'Tequila';
   print qq{Content-Type: text/html;charset=iso-8859-1
 
       <html>
         <head>
           <title>$title</title>
         </head>
         <body>
   };
 }
 
 sub tail {
   print qq{
         </body>
       </html>
   };
   exit;
 }
 
 sub error {
   my ($self, $msg1, $testing, $msg2) = @_;
   my $server = $self->{localserver};
   head ('Tequila error');
   print qq{
       <table width="100%" height="100%"><tr><td valign="middle">
         <table width="600" border="1" cellspacing="0" align="center" cellpadding="5">
           <tr>
             <td bgcolor="#CCCCCC">
               <table width="100%">
                 <tr>
                   <td>
                     <img src="http://$server/images/logo.gif" alt="Local logo">
                   </td>
                   <td bgcolor="#CCCCCC" align="right">
                     <font size="+2">Service <b>$self->{service}</b></font>
                   </td>
                 </tr>
               </table>
             </td>
           </tr>  
           <tr>
             <td align="center"> 
               <table width="98%" cellspacing="0" bgcolor=white>
                 <tr>
                   <td width="219">
                     <img src="http://$server/images/eye.gif" width="200" height="270">
                   </td>
                   <td align="center" valign="middle">
                     <font color="red" size="+1">
                       Tequila error : $msg1
                       <h3 align="center">
                         Contact the manager of the application you
                         are trying to access.
                       </h3>
                     </font>
                   </td>
                 </tr>
               </table>
             </td>
           </tr>
         </table>
       </td></tr></table>
   };
   tail ();
 }
 
 sub getaddrs {
   my $srv = shift;
   my ($name, $aliases, $addrtype, $length, @addresses) = gethostbyname ($srv);
   next unless @addresses;
   foreach (@addresses) {
     $_ = join ('.', unpack ('C4', $_));
   }
   return @addresses;
 }
 
 sub createserverrequest {
   my   $self = shift;
   $self->{urlaccess} = $self->makeurlaccess () unless $self->{urlaccess};
   $self->{usecookie} = $self->{servercookies} ? '' : 'off';
 
 #
 #  We should use method POST, but we get trapped in the Apache infamous
 #  Method Not Allowed message.
 #
   my $method = 'GET';
   #my $method = 'POST';
   my $args;
   if ($self->{resource}) {
     $args->{resource} = $self->{resource};
     $args->{partner}  = $self->{partner} if $self->{partner};
   } else {
     foreach my $keyword (qw(partner resource origresource urlaccess service username
                 allows allsensitive request wish require wantright forcelogin
                 wantrole language identities usecookie authstrength debug allowedorgs
                 nochecksrchost charset)) {
       next unless $self->{$keyword};
       $args->{$keyword} = $self->{$keyword};
       $args->{$keyword} = escapeurl ($args->{$keyword}) if ($method eq 'GET');
     }
   }
   foreach my $key (keys %{$self->{clientargs}}) {
     next if $args->{$key};
     my $value = $self->{clientargs}->{$key};
     $value = escapeurl ($value) if ($method eq 'GET');
     $args->{$key} = $value;
   }
   $args->{dontappendkey} = 1 if $self->{usecookies};
   my    $server = $self->{localserver};
   my    $script = $self->{serverfile};
   my $serverurl = $self->{serverurl} || "http://$server$script";
   $serverurl    =~ s/\/tequila(\/|$)/\/tequilac$1/ if $self->{resource} || $self->{partner};
   $serverurl    =~ s/^http:/https:/ if $self->{checkcertificates} ||
                                        $self->{resource}          ||
                                        $self->{partner}           ||
                                        $self->{usessl};
   my ($status, $sock, $statusline) =
     $self->httpsocket ("$serverurl/createrequest", $method, $args);
 
   $self->error ("Bad connection to Tequila server ($serverurl), server says : $statusline")
     if ($status != 200);
 
   my $requestkey;
   my $nempty = 0;
   while (<$sock>) { # body
     last unless $_;
     s/^[\r\n]*$//;
     if (/^$/) {
       last if (++$nempty > 5);
     } else { $nempty = 0; }
     $requestkey = $1 if /^key=(.*)$/;
   }
   close ($sock);
   $self->error ("Bad response from local Tequila server ($server)") if !$requestkey;
   return $requestkey;
 }
 
 sub fetchattributes {
   my       $self = shift;
   my $requestkey = $self->{requestkey};
   my     $server = $self->{localserver};
   my  $serverurl = $self->{serverurl} || "http://$server/tequila";
   $serverurl     =~ s/\/tequila(\/|$)/\/tequilac$1/ if $self->{resource} || $self->{partner};
   $serverurl     =~ s/^http:/https:/ if $self->{checkcertificates} ||
                                        $self->{resource}          ||
                                        $self->{partner}           ||
                                        $self->{usessl};
 
   my $args = { key => $requestkey, };
   my ($status, $sock, $statusline) =
     $self->httpsocket ("$serverurl/fetchattributes", 'GET', $args);
 
   return if ($status == 451); # Invalid key.
   $self->error ("Bad connection to Tequila server ($serverurl), server says : $statusline")
     if ($status != 200);
 
   my ($org, $user, $host, $key, $sver, %attrs);
   while (<$sock>) { # body
     last unless $_;
     chomp;
     next if /^$/;
     if (/^([^=]+)=(.*)$/) {
       my ($name, $value) = ($1, $2);
       if    ($name eq     'org') { $org  = $value; }
       elsif ($name eq    'user') { $user = $value; }
       elsif ($name eq    'host') { $host = $value; }
       elsif ($name eq     'key') { $key  = $value; }
       elsif ($name eq 'version') { $sver = $value; }
       else {
         if ($value =~ /^\\/) {
           $value = '';
           while (<$sock>) {
             last if /^[\r\n]*$/;
             $value .= $_;
           }
         }
         $attrs {$name} = $value;
       }
     }
   }
   close ($sock);
   $self->error ("Tequila:fetchattributes: Malformed server response : org undefined")
     unless $org;
   $self->error ("Tequila:fetchattributes: Malformed server response : user undefined")
     unless $user;
   $self->error ("Tequila:fetchattributes: Malformed server response : host undefined")
     unless $host;
   $self->error ("Tequila:fetchattributes: Malformed server response : key undefined")
     unless $key;
 
   $self->{org}     = $org;
   $self->{user}    = $user;
   $self->{host}    = $host;
   $self->{version} = $sver;
   $self->{attrs}   = \%attrs;
 
   $self->checkuserprofile (1);
   if ($self->{usesessions}) {
     $self->{sessionkey} = $self->genkey ();
     $self->createsession ();
   }
   return 1;
 }
 
 sub makeurlaccess () {
   my  $self = shift;
   my    $qs = $self->{querystring};
   my    $pi = $self->{pathinfo};
   my    $me = $self->{scriptname};
   my    $us = $self->{servername};
   my $proto = ($self->{https} && ($self->{https} eq 'on')) ? "https" : "http";
   my $urlaccess = "$proto://$us$me$pi";
   $urlaccess .= "?$qs" if $qs;
   return $urlaccess;
 }
 
 sub depositcookie {
   my ($self, $cook, $value) = @_;
   return unless $cook;
   my $date = gmtime (time + $self->{sessionmax});
   my ($day, $month, $daynum, $hms, $year) = split (/\s+/, $date);
   my $expires = sprintf ("%s %02d-%s-%s %s GMT", $day, $daynum, $month, $year, $hms);
   if ($self->{cookiepolicy} eq 'session') {
     print qq{Set-Cookie: $cook=$value; path=/;\r\n};
   } else {
     print qq{Set-Cookie: $cook=$value; path=/; expires=$expires;\r\n};
   }
 }
 
 sub removecookie {
   my ($self, $cook) = @_;
   my $date = gmtime (time - 3600);
   my ($day, $month, $daynum, $hms, $year) = split (/\s+/, $date);
   my $expires = sprintf ("%s %02d-%s-%s %s GMT", $day, $daynum, $month, $year, $hms);
   print qq{Set-Cookie: $cook=removed; path=/; expires=$expires;\r\n};
 }
 
 sub staticinit {
   my ($localserver, $serverurl, $sessionsdir);
   if (open (CONF, "/etc/tequila.conf")) {
     while (<CONF>) {
       chomp;
       next if (/^#/ || /^$/);
       $localserver = $1 if /^TequilaServer:\s*(.*)$/i;
       $serverurl   = $1 if /^TequilaServerUrl:\s*(.*)$/i;
       $sessionsdir = $1 if /^SessionsDir:\s*(.*)$/i;
     }
     close (CONF);
   }
   unless ($sessionsdir) {
     if (eval "use Tequila::Config; 1;") {
       $localserver = $Tequila::Config::server;
       $serverurl   = $Tequila::Config::serverurl;
       $sessionsdir = $Tequila::Config::sessionsdir;
     }
   }
   
   my @tried;
   unless ($sessionsdir) {
     my $scriptfile = $ENV {SCRIPT_FILENAME};
     $scriptfile =~ s/\/[^\/]*$//;
     my $sesdir = "$scriptfile/config/Sessions";
     push (@tried, $sesdir);
     if (-d $sesdir && -w $sesdir) {
       $sessionsdir = $sesdir;
     }
   }
   unless ($sessionsdir) {
     my @sessionsdirs = (
       '/var/www/Tequila/Sessions',
       '/var/www/tequila/Tequila/Sessions',
     );
     foreach my $sesdir (@sessionsdirs) {
       push (@tried, $sesdir);
       if (-d $sesdir && -w $sesdir) {
         $sessionsdir = $sesdir;
         last;
       }
     }
   }
   my $sesdir = $ENV {DOCUMENT_ROOT};
   unless ($sessionsdir) { 
     $sesdir =~ s!/[^/]*/*$!/Sessions!;  # One step over DOCUMENT_ROOT.
     push (@tried, $sesdir);
     if (-d $sesdir && -w $sesdir) {
       $sessionsdir = $sesdir;
     }
   }
   unless ($sessionsdir) { 
     $sesdir =~ s!/Sessions$!/Tequila/Sessions!;
     push (@tried, $sesdir);
     if (-d $sesdir && -w $sesdir) {
       $sessionsdir = $sesdir;
     }
   }
   unless ($sessionsdir) { 
     $sesdir =~ s!/Tequila/Sessions$!/private/Tequila/Sessions!;
     push (@tried, $sesdir);
     if (-d $sesdir && -w $sesdir) {
       $sessionsdir = $sesdir;
     }
   }
   unless ($sessionsdir) {
     my $self = { org => 'Unknown yet', service => 'Unknown yet', };
     bless $self, 'Tequila::Client';
     my $tried = join (', ', @tried);
     $self->error ("Unable to find the Session directory, (tried $tried).");
   }
   unless ($localserver) {
     my $hostname = `hostname`;
     chomp $hostname;
     if ($hostname !~ /\./) {
       my  $addr = gethostbyname ($hostname);
       $hostname = gethostbyaddr ($addr, AF_INET);
     }
     my $localdomain = $1 if ($hostname =~ /^[^\.]*\.(.*)$/);
     unless ($localserver) {
       $localserver  = "tequila";
       $localserver .= ".$localdomain" if $localdomain;
     }
   }
   unless ($serverurl) {
     $serverurl  = "https://$localserver/tequila";
   }
   $defaultserver      = $localserver;
   $defaultsessionsdir = $sessionsdir;
   $defaultserverurl   = $serverurl;
 }
 
 sub escapeurl {
   local ($_) = @_;
   s/([^\w\+\.\-])/sprintf("%%%X",ord($1))/ge;
   return $_;
 }
 
 sub getrandombytes {
   my ($self, $len) = @_;
   $len ||= 32;
   my $bytes;
   open(RAND, "/dev/urandom") || do {
     $self->error ("Internal error in getrandombytes : ".
                   "unable to init random engine : $!.")
   };
   if (sysread (RAND, $bytes, $len) != $len) {
     $self->error ("Internal error in getrandombytes : ".
                   "Unable to read random bytes : $!");
   }
   close (RAND);
   return $bytes;
 }
 
 sub genkey {
   my ($self, $len) = @_;
   $len ||= 32;
   my $bytes = $self->getrandombytes ($len);
   my @bytes = unpack ("C$len", $bytes);
   my   $key = '';
   for (my $i = 0; $i < $len; $i++) {
     my $car = $bytes [$i] % 36;
     $key .= ('a'..'z', '0'..'9')[$car];
   }
   return $key;
 }
 
 sub httpsocket {
   my ($self, $url, $method, $args) = @_;
   my $sock;
   my $nredir = 0;
   while ($url) {
     $self->error ("Tequila:httpsocket: invalid URL : $url")
       if ($url !~ m!^(http|https)://([^/]*)(.*)$!);
     my ($prot, $host, $file, $port) = ($1, $2, $3, 0);
     ($host, $port) = split (/:/, $host) if ($host =~ /:/);
     unless ($port) {
       $port = ($prot eq 'https') ? 443 : 80;
     }
     $sock = ($prot eq 'https')
       ? $self->sslsocket ($host, $port)
       : new IO::Socket::INET ("$host:$port");
     $self->error ("Tequila:httpsocket: unable to open $prot socket connection to $host (for $url)")
       unless $sock;
 
     if ($method eq 'POST') {
       my $argstring = '';
       foreach my $arg (keys %$args) {
         $argstring .= "$arg=$args->{$arg}\n";
       }
       my $arglen = length ($argstring);
       print $sock "POST $file HTTP/1.0\r\n",
                   "Host: $host\r\n",
                   "Content-type: application/x-www-form-urlencoded\r\n",
                   "Content-length: $arglen\r\n",
                   "\r\n",
                   "$argstring" ||
         $self->error ("Tequila:httpsocket: unable to send data to $host:$port");
     } else {
       my $argstring = '';
       foreach my $arg (keys %$args) {
         $argstring .= "&$arg=$args->{$arg}";
       }
       $argstring =~ s/^&//;
       print $sock "GET $file?$argstring HTTP/1.0\r\n",
                   "Host: $host\r\n",
                   "\r\n" ||
         $self->error ("Tequila:httpsocket: unable to send data to $host:$port");
     }
     $url = 0;
     my $statusline = <$sock>;
     $statusline = <$sock> unless $statusline;
     $statusline =~ s/[\r\n]//g;
     return (452, $sock, "No answer from server") unless $statusline;
     my ($status) = ($statusline =~ / (\d*) /); # HTTP/1.x 200 OK
     while (<$sock>) { # headers
       last unless $_;
       s/^[\r\n]*$//;
       if (/^Location:\s*(.*)$/) {
         $url = $1;
       }
       last if /^$/;
     }
     if (($status != 200) && !$url) {
       return ($status, $sock, $statusline);
     }
     if ($url) {
       close ($sock);
       $nredir++;
       $self->error ("Tequila:httpsocket: maximun number of HTTP redirect : $nredir")
         if ($nredir > 20);
     }
   }
   return (200, $sock);
 }
 
 sub sslsocket {
   my ($self, $server, $port) = @_;
   $port = 'https' unless $port;
   my ($sock, %sslargs);
   $sslargs {PeerAddr} = "$server:$port";
   if ($self->{checkcertificates} && $self->{cafile}) {
     $sslargs {SSL_verify_mode} = 0x01;
     $sslargs {SSL_ca_file}     = $self->{cafile};
   }
   if ($self->{keyfile} && $self->{certfile}) {
     $sslargs {SSL_use_cert}  = 1;
     $sslargs {SSL_key_file}  = $self->{keyfile};
     $sslargs {SSL_cert_file} = $self->{certfile};
   }
+  $sslargs {SSL_fingerprint} = $ENV {TEQUILA_FINGERPRINT} if $ENV {TEQUILA_FINGERPRINT} && $ENV {TEQUILA_FINGERPRINT} ne '';
   $sock = new IO::Socket::SSL (%sslargs);
 
   if ($self->{checkcertificates} && $self->{cafile}) {
     my $subject = $sock->peer_certificate ('subject');
     my @cns = split (/\/CN=/i, $subject);
     shift @cns;
     my $ok = 0;
     foreach my $cn (@cns) {
       if ($cn =~ /^\((.*)\)(.*)$/) {
         my $domain = $2;
         my @names = split (/\|/, $1);
         foreach my $name (@names) {
           my $fdqn = $name . $domain;
           if (uc $server eq uc $fdqn) { $ok = 1; last; }
         }
         last if $ok;
       } else {
         if (uc $server eq uc $cn) { $ok = 1; last; }
       }
       $self->error ("Tequila:sslsocket: invalid certificate for $server : $subject") unless $ok;
     }
   }
   return $sock;
 }
 
 sub checksessionkey {
   my ($self, $sessionkey) = @_;
   unless ($sessionkey =~ /^[a-z0-9]+$/i) {
     $sessionkey = fixmsg ($sessionkey);
     $self->error ("Tequila: Malformed session key : $sessionkey");
   }
 }
 
 sub fixmsg {
   my $msg = shift;
   $msg =~ s/</&lt;/g;
   $msg =~ s/>/&gt;/g;
   return $msg;
 }
 
 
 1;