[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.147 and 1.158

version 1.147, 2001/08/09 19:28:47 version 1.158, 2001/09/21 20:38:10
Line 72 Line 72
 # EXT(name)          : value of a variable  # EXT(name)          : value of a variable
 # symblist(map,hash) : Updates symbolic storage links  # symblist(map,hash) : Updates symbolic storage links
 # symbread([filename]) : returns the data handle (filename optional)  # symbread([filename]) : returns the data handle (filename optional)
 # rndseed()          : returns a random seed   # rndseed([symb,courseid,domain,uname])
   #                    : returns a random seed, all arguments are optional,
   #                      if they aren't sent it use the environment to derive
   #                      them
   #                      Note: if symb isn't sent and it can't get one from
   #                      &symbread it will use the current time as it's return
 # receipt()          : returns a receipt to be given out to users   # receipt()          : returns a receipt to be given out to users 
 # getfile(filename)  : returns the contents of filename, or a -1 if it can't  # getfile(filename)  : returns the contents of filename, or a -1 if it can't
 #                      be found, replicates and subscribes to the file  #                      be found, replicates and subscribes to the file
Line 122 Line 127
 # 5/30 H. K. Ng  # 5/30 H. K. Ng
 # 6/1 Gerd Kortemeyer  # 6/1 Gerd Kortemeyer
 # July Guy Albertelli  # July Guy Albertelli
 # 8/4,8/7,8/8,8/9 Gerd Kortemeyer  # 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21 Gerd Kortemeyer
   
 package Apache::lonnet;  package Apache::lonnet;
   
Line 131  use Apache::File; Line 136  use Apache::File;
 use LWP::UserAgent();  use LWP::UserAgent();
 use HTTP::Headers;  use HTTP::Headers;
 use vars   use vars 
 qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache %packagetab);  qw(%perlvar %hostname %homecache %hostip %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache %packagetab %courselogs);
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
 use Apache::Constants qw(:common :http);  use Apache::Constants qw(:common :http);
Line 276  sub appenv { Line 281  sub appenv {
     map {      map {
  if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {   if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
             &logthis("<font color=blue>WARNING: ".              &logthis("<font color=blue>WARNING: ".
                 "Attempt to modify environment ".$_." to ".$newenv{$_});                  "Attempt to modify environment ".$_." to ".$newenv{$_}
                   .'</font>');
     delete($newenv{$_});      delete($newenv{$_});
         } else {          } else {
             $ENV{$_}=$newenv{$_};              $ENV{$_}=$newenv{$_};
Line 659  sub log { Line 665  sub log {
     return critical("log:$dom:$nam:$what",$hom);      return critical("log:$dom:$nam:$what",$hom);
 }  }
   
   # ------------------------------------------------------------------ Course Log
   
   sub flushcourselogs {
       &logthis('Flushing course log buffers');
       map {
           my $crsid=$_;
           if (&reply('log:'.$ENV{'course.'.$crsid.'.domain'}.':'.
             $ENV{'course.'.$crsid.'.num'}.':'.
              &escape($courselogs{$crsid}),
             $ENV{'course.'.$crsid.'.home'}) eq 'ok') {
       delete $courselogs{$crsid};
           } else {
               &logthis('Failed to flush log buffer for '.$crsid);
               if (length($courselogs{$crsid})>40000) {
                  &logthis("<font color=blue>WARNING: Buffer for ".$crsid.
                           " exceeded maximum size, deleting.</font>");
                  delete $courselogs{$crsid};
               }
           }        
       } keys %courselogs;
   }
   
   sub courselog {
       my $what=shift;
       $what=time.':'.$what;
       unless ($ENV{'request.course.id'}) { return ''; }
       if (defined $courselogs{$ENV{'request.course.id'}}) {
    $courselogs{$ENV{'request.course.id'}}.='&'.$what;
       } else {
    $courselogs{$ENV{'request.course.id'}}.=$what;
       }
       if (length($courselogs{$ENV{'request.course.id'}})>4048) {
    &flushcourselogs();
       }
   }
   
   sub courseacclog {
       my $fnsymb=shift;
       unless ($ENV{'request.course.id'}) { return ''; }
       my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
       if ($what=~/(problem|exam|quiz|assess|survey|form)$/) {
    map {
               if ($_=~/^form\.(.*)/) {
    $what.=':'.$1.'='.$ENV{$_};
               }
           } keys %ENV;
       }
       &courselog($what);
   }
   
   # ----------------------------------------------------------- Check out an item
   
   sub checkout {
       my ($symb,$tuname,$tudom,$tcrsid)=@_;
       my $now=time;
       my $lonhost=$perlvar{'lonHostID'};
       my $infostr=&escape(
                    $tuname.'&'.
                    $tudom.'&'.
                    $tcrsid.'&'.
                    $symb.'&'.
    $now.'&'.$ENV{'REMOTE_ADDR'});
       my $token=&reply('tmpput:'.$infostr,$lonhost);
       if ($token=~/^error\:/) { 
           &logthis("<font color=blue>WARNING: ".
                   "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
                    "</font>");
           return ''; 
       }
   
       $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
       $token=~tr/a-z/A-Z/;
   
       my %infohash=('resource.0.outtoken' => $token,
                     'resource.0.checkouttime' => $now,
                     'resource.0.outremote' => $ENV{'REMOTE_ADDR'});
   
       unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
          return '';
       } else {
           &logthis("<font color=blue>WARNING: ".
                   "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
                    "</font>");
       }    
   
       if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
                            &escape('Checkout '.$infostr.' - '.
                                                    $token)) ne 'ok') {
    return '';
       } else {
           &logthis("<font color=blue>WARNING: ".
                   "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
                    "</font>");
       }
       return $token;
   }
   
   # ------------------------------------------------------------ Check in an item
   
   sub checkin {
       my $token=shift;
       my $now=time;
       my ($ta,$tb,$lonhost)=split(/\*/,$token);
       $lonhost=~tr/A-Z/a-z/;
       my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;
       $dtoken=~s/\W/\_/g;
       my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
                    split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
   
       unless (($tuname) && ($tudom)) {
           &logthis('Check in '.$token.' ('.$dtoken.') failed');
           return '';
       }
       
       unless (&allowed('mgr',$tcrsid)) {
           &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
                    $ENV{'user.name'}.' - '.$ENV{'user.domain'});
           return '';
       }
   
       my %infohash=('resource.0.intoken' => $token,
                     'resource.0.checkintime' => $now,
                     'resource.0.inremote' => $ENV{'REMOTE_ADDR'});
   
       unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
          return '';
       }    
   
       if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
                            &escape('Checkin - '.$token)) ne 'ok') {
    return '';
       }
   
       return ($symb,$tuname,$tudom,$tcrsid);    
   }
   
 # --------------------------------------------- Set Expire Date for Spreadsheet  # --------------------------------------------- Set Expire Date for Spreadsheet
   
 sub expirespread {  sub expirespread {
Line 1035  sub eget { Line 1177  sub eget {
   
 sub allowed {  sub allowed {
     my ($priv,$uri)=@_;      my ($priv,$uri)=@_;
   
       my $orguri=$uri;
     $uri=&declutter($uri);      $uri=&declutter($uri);
   
 # Free bre access to adm and meta resources  # Free bre access to adm and meta resources
Line 1108  sub allowed { Line 1252  sub allowed {
            }             }
        }         }
                 
        if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {         if ($checkreferer) {
   my $refuri=$ENV{'HTTP_REFERER'};    my $refuri=$ENV{'httpref.'.$orguri};
           $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;  
           $refuri=&declutter($refuri);              unless ($refuri) {
                   map {
       if ($_=~/^httpref\..*\*/) {
    my $pattern=$_;
                           $pattern=~s/^httpref\.\/res\///;
                           $pattern=~s/\*/\[\^\/\]\+/g;
                           $pattern=~s/\//\\\//g;
                           if ($orguri=~/$pattern/) {
       $refuri=$ENV{$_};
                           }
                       }
                   } keys %ENV;
               }
            if ($refuri) { 
     $refuri=&declutter($refuri);
           my @uriparts=split(/\//,$refuri);            my @uriparts=split(/\//,$refuri);
           my $filename=$uriparts[$#uriparts];            my $filename=$uriparts[$#uriparts];
           my $pathname=$refuri;            my $pathname=$refuri;
           $pathname=~s/\/$filename$//;            $pathname=~s/\/$filename$//;
           my @filenameparts=split(/\./,$uri);  
           if (&fileembstyle($filenameparts[$#filenameparts]) ne 'ssi') {  
             if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~              if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
               /\&$filename\:([\d\|]+)\&/) {                /\&$filename\:([\d\|]+)\&/) {
               my $refstatecond=$1;                my $refstatecond=$1;
Line 1127  sub allowed { Line 1283  sub allowed {
                   $uri=$refuri;                    $uri=$refuri;
                   $statecond=$refstatecond;                    $statecond=$refstatecond;
               }                }
             }  
           }            }
           }
        }         }
    }     }
   
Line 2044  sub numval { Line 2200  sub numval {
 }      }    
   
 sub rndseed {  sub rndseed {
     my $symb;      my ($symb,$courseid,$domain,$username)=@_;
     unless ($symb=&symbread()) { return time; }      if (!$symb) {
     {         unless ($symb=&symbread()) { return time; }
       }
       if (!$courseid) { $courseid=$ENV{'request.course.id'};}
       if (!$domain) {$domain=$ENV{'user.domain'};}
       if (!$username) {$username=$ENV{'user.name'};}
       {
       use integer;        use integer;
       my $symbchck=unpack("%32C*",$symb) << 27;        my $symbchck=unpack("%32C*",$symb) << 27;
       my $symbseed=numval($symb) << 22;        my $symbseed=numval($symb) << 22;
       my $namechck=unpack("%32C*",$ENV{'user.name'}) << 17;        my $namechck=unpack("%32C*",$username) << 17;
       my $nameseed=numval($ENV{'user.name'}) << 12;        my $nameseed=numval($username) << 12;
       my $domainseed=unpack("%32C*",$ENV{'user.domain'}) << 7;        my $domainseed=unpack("%32C*",$domain) << 7;
       my $courseseed=unpack("%32C*",$ENV{'request.course.id'});        my $courseseed=unpack("%32C*",$courseid);
       my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;        my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
       #uncommenting these lines can break things!        #uncommenting these lines can break things!
       #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");        #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
Line 2175  if ($readit ne 'done') { Line 2336  if ($readit ne 'done') {
     my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");      my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
          chomp($configline);
        my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);         my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
        $hostname{$id}=$name;         $hostname{$id}=$name;
        $hostdom{$id}=$domain;         $hostdom{$id}=$domain;
          $hostip{$id}=$ip;
        if ($role eq 'library') { $libserv{$id}=$name; }         if ($role eq 'library') { $libserv{$id}=$name; }
     }      }
 }  }
Removed from v.1.147  
changed lines
  Added in v.1.158

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