[BACK]Return to lonnet.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.782 and 1.783

version 1.782, 2006/09/19 19:03:24 version 1.783, 2006/09/19 21:36:41
Line 292  sub error { Line 292  sub error {
     return undef;      return undef;
 }  }
   
   sub convert_and_load_session_env {
       my ($lonidsdir,$handle)=@_;
       my @profile;
       {
    open(my $idf,"$lonidsdir/$handle.id");
    flock($idf,LOCK_SH);
    @profile=<$idf>;
    close($idf);
       }
       my %temp_env;
       foreach my $line (@profile) {
    chomp($line);
    my ($envname,$envvalue)=split(/=/,$line,2);
    $temp_env{&unescape($envname)} = &unescape($envvalue);
       }
       unlink("$lonidsdir/$handle.id");
       if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(),
       0640)) {
    %disk_env = %temp_env;
    @env{keys(%temp_env)} = @disk_env{keys(%temp_env)};
    untie(%disk_env);
       }
   }
   
 # ------------------------------------------- Transfer profile into environment  # ------------------------------------------- Transfer profile into environment
 my $env_loaded;  my $env_loaded;
 sub transfer_profile_to_env {  sub transfer_profile_to_env {
Line 305  sub transfer_profile_to_env { Line 329  sub transfer_profile_to_env {
         ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );          ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
     }      }
   
     my @profile;      my %remove;
     {      if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),
  open(my $idf,"$lonidsdir/$handle.id");      0640)) {
  flock($idf,LOCK_SH);   @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
  @profile=<$idf>;   untie(%disk_env);
  close($idf);      } else {
    &convert_and_load_session_env($lonidsdir,$handle);
     }      }
     my $envi;  
     my %Remove;      while ( my $envname = each(%env) ) {
     for ($envi=0;$envi<=$#profile;$envi++) {  
  chomp($profile[$envi]);  
  my ($envname,$envvalue)=split(/=/,$profile[$envi],2);  
  $envname=&unescape($envname);  
  $envvalue=&unescape($envvalue);  
  $env{$envname} = $envvalue;  
         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {          if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
             if ($time < time-300) {              if ($time < time-300) {
                 $Remove{$key}++;                  $remove{$key}++;
             }              }
         }          }
     }      }
   
     $env{'user.environment'} = "$lonidsdir/$handle.id";      $env{'user.environment'} = "$lonidsdir/$handle.id";
     $env_loaded=1;      $env_loaded=1;
     foreach my $expired_key (keys(%Remove)) {      foreach my $expired_key (keys(%remove)) {
         &delenv($expired_key);          &delenv($expired_key);
     }      }
 }  }
Line 347  sub appenv { Line 367  sub appenv {
             $env{$key}=$newenv{$key};              $env{$key}=$newenv{$key};
         }          }
     }      }
     foreach my $key (keys(%newenv)) {      if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
  my $value = &escape($newenv{$key});      0640)) {
  delete($newenv{$key});   while (my ($key,$value) = each(%newenv)) {
  $newenv{&escape($key)}=$value;      $disk_env{$key} = $value;
     }  
   
     my $lockfh;  
     unless (open($lockfh,"$env{'user.environment'}")) {  
  return 'error: '.$!;  
     }  
     unless (flock($lockfh,LOCK_EX)) {  
          &logthis("<font color=\"blue\">WARNING: ".  
                   'Could not obtain exclusive lock in appenv: '.$!);  
          close($lockfh);  
          return 'error: '.$!;  
     }  
   
     my @oldenv;  
     {  
  my $fh;  
  unless (open($fh,"$env{'user.environment'}")) {  
     return 'error: '.$!;  
  }  
  @oldenv=<$fh>;  
  close($fh);  
     }  
     for (my $i=0; $i<=$#oldenv; $i++) {  
         chomp($oldenv[$i]);  
         if ($oldenv[$i] ne '') {  
     my ($name,$value)=split(/=/,$oldenv[$i],2);  
     unless (defined($newenv{$name})) {  
  $newenv{$name}=$value;  
     }  
         }  
     }  
     {  
  my $fh;  
  unless (open($fh,">$env{'user.environment'}")) {  
     return 'error';  
  }   }
  my $newname;   untie(%disk_env);
  foreach $newname (keys %newenv) {  
     print $fh $newname.'='.$newenv{$newname}."\n";  
  }  
  close($fh);  
     }      }
   
     close($lockfh);  
     return 'ok';      return 'ok';
 }  }
 # ----------------------------------------------------- Delete from Environment  # ----------------------------------------------------- Delete from Environment
Line 406  sub delenv { Line 385  sub delenv {
                 "Attempt to delete from environment ".$delthis);                  "Attempt to delete from environment ".$delthis);
         return 'error';          return 'error';
     }      }
     my @oldenv;      if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
     {      0640)) {
  my $fh;   foreach my $key (keys(%disk_env)) {
  unless (open($fh,"$env{'user.environment'}")) {      if ($key=~/^$delthis/) { 
     return 'error';  
  }  
  unless (flock($fh,LOCK_SH)) {  
     &logthis("<font color=\"blue\">WARNING: ".  
      'Could not obtain shared lock in delenv: '.$!);  
     close($fh);  
     return 'error: '.$!;  
  }  
  @oldenv=<$fh>;  
  close($fh);  
     }  
     {  
  my $fh;  
  unless (open($fh,">$env{'user.environment'}")) {  
     return 'error';  
  }  
  unless (flock($fh,LOCK_EX)) {  
     &logthis("<font color=\"blue\">WARNING: ".  
      'Could not obtain exclusive lock in delenv: '.$!);  
     close($fh);  
     return 'error: '.$!;  
  }  
  foreach my $cur_key (@oldenv) {  
     my $unescaped_cur_key = &unescape($cur_key);  
     if ($unescaped_cur_key=~/^$delthis/) {   
                 my ($key) = split('=',$cur_key,2);  
  $key = &unescape($key);  
                 delete($env{$key});                  delete($env{$key});
             } else {                  delete($disk_env{$key});
                 print $fh $cur_key;   
             }              }
  }   }
  close($fh);   untie(%disk_env);
     }      }
     return 'ok';      return 'ok';
 }  }
Line 1193  sub ssi_body { Line 1144  sub ssi_body {
   
 sub absolute_url {  sub absolute_url {
     my ($host_name) = @_;      my ($host_name) = @_;
       my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
       if ($host_name eq '') {
    $host_name = $ENV{'SERVER_NAME'};
       }
       return $protocol.$host_name;
   }
   
   sub absolute_url {
       my ($host_name) = @_;
     my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');      my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
     if ($host_name eq '') {      if ($host_name eq '') {
  $host_name = $ENV{'SERVER_NAME'};   $host_name = $ENV{'SERVER_NAME'};
Removed from v.1.782  
changed lines
  Added in v.1.783

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>