[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.545.2.2 and 1.567

version 1.545.2.2, 2004/10/12 20:26:48 version 1.567, 2004/11/10 19:03:04
Line 36  use HTTP::Date; Line 36  use HTTP::Date;
 # use Date::Parse;  # use Date::Parse;
 use vars   use vars 
 qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom   qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
    %libserv %pr %prp $metacache %packagetab %titlecache %courseresversioncache %resversioncache     %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
    %courselogs %accesshash %userrolehash $processmarker $dumpcount      %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache      %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache 
    %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def      %userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def 
    %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);     %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit);
   
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
 use Apache::Constants qw(:common :http);  use Apache::Constants qw(:common :http);
 use HTML::LCParser;  use HTML::LCParser;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
 use Apache::loncoursedata;  
 use Apache::lonlocal;  use Apache::lonlocal;
 use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);  use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
 use Time::HiRes qw( gettimeofday tv_interval );  use Time::HiRes qw( gettimeofday tv_interval );
 use Cache::Memcached;  
 my $readit;  my $readit;
   my $max_connection_retries = 10;     # Or some such value.
   
 =pod  =pod
   
Line 116  sub logperm { Line 115  sub logperm {
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
 sub subreply {  sub subreply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     my $t0_f=[&Time::HiRes::gettimeofday()];  
     my $peerfile="$perlvar{'lonSockDir'}/$server";      my $peerfile="$perlvar{'lonSockDir'}/$server";
     my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",      #
                                      Type    => SOCK_STREAM,      #  With loncnew process trimming, there's a timing hole between lonc server
                                      Timeout => 10)      #  process exit and the master server picking up the listen on the AF_UNIX
        or return "con_lost";      #  socket.  In that time interval, a lock file will exist:
     print $client "$cmd\n";  
     my $answer=<$client>;      my $lockfile=$peerfile.".lock";
     if (!$answer) { $answer="con_lost"; }      while (-e $lockfile) { # Need to wait for the lockfile to disappear.
     chomp($answer);   sleep(1);
     my $td=&Time::HiRes::tv_interval($t0_f);      }
     &Apache::lonnet::logthis("\n $td seconds for $cmd");      # At this point, either a loncnew parent is listening or an old lonc
       # or loncnew child is listening so we can connect or everything's dead.
       #
       #   We'll give the connection a few tries before abandoning it.  If
       #   connection is not possible, we'll con_lost back to the client.
       #   
       my $client;
       for (my $retries = 0; $retries < $max_connection_retries; $retries++) {
    $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
         Type    => SOCK_STREAM,
         Timeout => 10);
    if($client) {
       last; # Connected!
    }
    sleep(1); # Try again later if failed connection.
       }
       my $answer;
       if ($client) {
    print $client "$cmd\n";
    $answer=<$client>;
    if (!$answer) { $answer="con_lost"; }
    chomp($answer);
       } else {
    $answer = 'con_lost'; # Failed connection.
       }
     return $answer;      return $answer;
 }  }
   
Line 438  sub overloaderror { Line 460  sub overloaderror {
     if ($overload>0) {      if ($overload>0) {
  $r->err_headers_out->{'Retry-After'}=$overload;   $r->err_headers_out->{'Retry-After'}=$overload;
         $r->log_error('Overload of '.$overload.' on '.$checkserver);          $r->log_error('Overload of '.$overload.' on '.$checkserver);
         return 409;          return 413;
     }          }    
     return '';      return '';
 }  }
Line 775  sub getsection { Line 797  sub getsection {
     my ($udom,$unam,$courseid)=@_;      my ($udom,$unam,$courseid)=@_;
     $courseid=~s/\_/\//g;      $courseid=~s/\_/\//g;
     $courseid=~s/^(\w)/\/$1/;      $courseid=~s/^(\w)/\/$1/;
   
       my $hashid="$udom:$unam:$courseid";
       my ($result,$cached)=&is_cached(\%getsectioncache,$hashid,'getsection');
       if (defined($cached)) { return $result; }
   
     my %Pending;       my %Pending; 
     my %Expired;      my %Expired;
     #      #
Line 799  sub getsection { Line 826  sub getsection {
         if ($key eq $courseid.'_st') { $section=''; }          if ($key eq $courseid.'_st') { $section=''; }
         my ($dummy,$end,$start)=split(/\_/,&unescape($value));          my ($dummy,$end,$start)=split(/\_/,&unescape($value));
         my $now=time;          my $now=time;
         if (defined($end) && ($now > $end)) {          if (defined($end) && $end && ($now > $end)) {
             $Expired{$end}=$section;              $Expired{$end}=$section;
             next;              next;
         }          }
         if (defined($start) && ($now < $start)) {          if (defined($start) && $start && ($now < $start)) {
             $Pending{$start}=$section;              $Pending{$start}=$section;
             next;              next;
         }          }
         return $section;          return &do_cache(\%getsectioncache,$hashid,$section,'getsection');
     }      }
     #      #
     # Presumedly there will be few matching roles from the above      # Presumedly there will be few matching roles from the above
     # loop and the sorting time will be negligible.      # loop and the sorting time will be negligible.
     if (scalar(keys(%Pending))) {      if (scalar(keys(%Pending))) {
         my ($time) = sort {$a <=> $b} keys(%Pending);          my ($time) = sort {$a <=> $b} keys(%Pending);
         return $Pending{$time};          return &do_cache(\%getsectioncache,$hashid,$Pending{$time},'getsection');
     }       } 
     if (scalar(keys(%Expired))) {      if (scalar(keys(%Expired))) {
         my @sorted = sort {$a <=> $b} keys(%Expired);          my @sorted = sort {$a <=> $b} keys(%Expired);
         my $time = pop(@sorted);          my $time = pop(@sorted);
         return $Expired{$time};          return &do_cache(\%getsectioncache,$hashid,$Expired{$time},'getsection');
     }      }
     return '-1';      return &do_cache(\%getsectioncache,$hashid,'-1','getsection');
 }  }
   
   
Line 877  sub is_cached { Line 904  sub is_cached {
 # &logthis("Upping $mtime - ".$$cache{$id.'.time'}.  # &logthis("Upping $mtime - ".$$cache{$id.'.time'}.
 # "$id because of $filename");  # "$id because of $filename");
     } else {      } else {
 # &logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'})));   &logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'})));
  &devalidate_cache($cache,$id,$name);   &devalidate_cache($cache,$id,$name);
  return (undef,undef);   return (undef,undef);
     }      }
Line 1012  EVALBLOCK Line 1039  EVALBLOCK
 #    &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));  #    &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));
 }  }
   
 sub devalidate_cache_new {  
     my ($cache,$name,$id) = @_;  
     if (0) { &Apache::lonnet::logthis("deleting $name:$id"); }  
     $cache->delete(&escape($name.':'.$id));  
 }  
   
 my $lastone;  
 my $lastname;  
 sub is_cached_new {  
     my ($cache,$name,$id,$debug) = @_;  
     $debug=0;  
     $id=&escape($name.':'.$id);  
     if ($lastname eq $id) {  
  if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $lastone <= $lastname "); }  
  return ($lastone,1);  
     }  
     undef($lastone);  
     undef($lastname);  
     my $value = $cache->get($id);  
     if (!(defined($value))) {  
  if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }  
  return (undef,undef);  
     }  
     $lastname=$id;  
     if ($value eq '__undef__') {  
  if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }  
  return (undef,1);  
     }  
     if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }  
     $lastone=$value;  
     return ($value,1);  
 }  
   
 sub do_cache_new {  
     my ($cache,$name,$id,$value,$time,$debug) = @_;  
     $debug=0;  
     $id=&escape($name.':'.$id);  
     my $setvalue=$value;  
     if (!defined($setvalue)) {  
  $setvalue='__undef__';  
     }  
     if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }  
     $cache->set($id,$setvalue,300);  
     return $value;  
 }  
   
 sub usection {  
     my ($udom,$unam,$courseid)=@_;  
     my $hashid="$udom:$unam:$courseid";  
       
     my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection');  
     if (defined($cached)) { return $result; }  
     $courseid=~s/\_/\//g;  
     $courseid=~s/^(\w)/\/$1/;  
     foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',  
                         &homeserver($unam,$udom)))) {  
         my ($key,$value)=split(/\=/,$_);  
         $key=&unescape($key);  
         if ($key=~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/) {  
             my $section=$1;  
             if ($key eq $courseid.'_st') { $section=''; }  
     my ($dummy,$end,$start)=split(/\_/,&unescape($value));  
             my $now=time;  
             my $notactive=0;  
             if ($start) {  
  if ($now<$start) { $notactive=1; }  
             }  
             if ($end) {  
                 if ($now>$end) { $notactive=1; }  
             }   
             unless ($notactive) {  
  return &do_cache(\%usectioncache,$hashid,$section,'usection');  
     }  
         }  
     }  
     return &do_cache(\%usectioncache,$hashid,'-1','usection');  
 }  
   
 # ------------------------------------- Read an entry from a user's environment  # ------------------------------------- Read an entry from a user's environment
   
 sub userenvironment {  sub userenvironment {
Line 1239  sub ssi_body { Line 1188  sub ssi_body {
     my ($filelink,%form)=@_;      my ($filelink,%form)=@_;
     my $output=($filelink=~/^http\:/?&externalssi($filelink):      my $output=($filelink=~/^http\:/?&externalssi($filelink):
                                      &ssi($filelink,%form));                                       &ssi($filelink,%form));
     $output=~      $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s*(-->)?\s||gs;
             s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;  
     $output=~s/^.*?\<body[^\>]*\>//si;      $output=~s/^.*?\<body[^\>]*\>//si;
     $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;      $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
     return $output;      return $output;
Line 1923  sub devalidate { Line 1871  sub devalidate {
         # - the student level sheet of this user in course's homespace          # - the student level sheet of this user in course's homespace
         # - the assessment level sheet for this resource           # - the assessment level sheet for this resource 
         #   for this user in user's homespace          #   for this user in user's homespace
    # - current conditional state info
  my $key=$uname.':'.$udom.':';   my $key=$uname.':'.$udom.':';
         my $status=          my $status=
     &del('nohist_calculatedsheets',      &del('nohist_calculatedsheets',
Line 1937  sub devalidate { Line 1886  sub devalidate {
                     $uname.' at '.$udom.' for '.                      $uname.' at '.$udom.' for '.
     $symb.': '.$status);      $symb.': '.$status);
         }          }
    &delenv('user.state.'.$cid);
     }      }
 }  }
   
Line 2256  sub tmprestore { Line 2206  sub tmprestore {
 }  }
   
 # ----------------------------------------------------------------------- Store  # ----------------------------------------------------------------------- Store
   
 sub store {  sub store {
     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;      my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
     my $home='';      my $home='';
Line 2269  sub store { Line 2220  sub store {
     if (!$stuname) { $stuname=$ENV{'user.name'}; }      if (!$stuname) { $stuname=$ENV{'user.name'}; }
   
     &devalidate($symb,$stuname,$domain);      &devalidate($symb,$stuname,$domain);
   
     $symb=escape($symb);      $symb=escape($symb);
     if (!$namespace) {       if (!$namespace) { 
        unless ($namespace=$ENV{'request.course.id'}) {          unless ($namespace=$ENV{'request.course.id'}) { 
Line 2304  sub cstore { Line 2256  sub cstore {
     if (!$stuname) { $stuname=$ENV{'user.name'}; }      if (!$stuname) { $stuname=$ENV{'user.name'}; }
   
     &devalidate($symb,$stuname,$domain);      &devalidate($symb,$stuname,$domain);
   
     $symb=escape($symb);      $symb=escape($symb);
     if (!$namespace) {       if (!$namespace) { 
        unless ($namespace=$ENV{'request.course.id'}) {          unless ($namespace=$ENV{'request.course.id'}) { 
Line 2346  sub restore { Line 2299  sub restore {
     if (!$domain) { $domain=$ENV{'user.domain'}; }      if (!$domain) { $domain=$ENV{'user.domain'}; }
     if (!$stuname) { $stuname=$ENV{'user.name'}; }      if (!$stuname) { $stuname=$ENV{'user.name'}; }
     if (!$home) { $home=$ENV{'user.home'}; }      if (!$home) { $home=$ENV{'user.home'}; }
   
     my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");      my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
   
     my %returnhash=();      my %returnhash=();
Line 2435  sub rolesinit { Line 2387  sub rolesinit {
     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);      my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }      if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
     my %allroles=();      my %allroles=();
     my %thesepriv=();  
     my $now=time;      my $now=time;
     my $userroles="user.login.time=$now\n";      my $userroles="user.login.time=$now\n";
     my $thesestr;  
   
     if ($rolesdump ne '') {      if ($rolesdump ne '') {
         foreach (split(/&/,$rolesdump)) {          foreach (split(/&/,$rolesdump)) {
Line 2446  sub rolesinit { Line 2396  sub rolesinit {
             my ($area,$role)=split(/=/,$_);              my ($area,$role)=split(/=/,$_);
             $area=~s/\_\w\w$//;              $area=~s/\_\w\w$//;
             my ($trole,$tend,$tstart)=split(/_/,$role);              my ($trole,$tend,$tstart)=split(/_/,$role);
             $userroles.='user.role.'.$trole.'.'.$area.'='.              $userroles.=&set_arearole($trole,$area,$tstart,$tend);
                         $tstart.'.'.$tend."\n";              if (($tend!=0) && ($tend<$now)) { $trole=''; }
 # log the associated role with the area              if (($tstart!=0) && ($tstart>$now)) { $trole=''; }
             &userrolelog($trole,$username,$domain,$area,$tstart,$tend);  
             if ($tend!=0) {  
         if ($tend<$now) {  
             $trole='';  
                 }   
             }  
             if ($tstart!=0) {  
                 if ($tstart>$now) {  
                    $trole='';          
                 }  
             }  
             if (($area ne '') && ($trole ne '')) {              if (($area ne '') && ($trole ne '')) {
  my $spec=$trole.'.'.$area;   my $spec=$trole.'.'.$area;
  my ($tdummy,$tdomain,$trest)=split(/\//,$area);   my ($tdummy,$tdomain,$trest)=split(/\//,$area);
  if ($trole =~ /^cr\//) {   if ($trole =~ /^cr\//) {
     my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);                      &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
      my $homsvr=homeserver($rauthor,$rdomain);  
     if ($hostname{$homsvr} ne '') {  
  my ($rdummy,$roledef)=  
    &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);  
   
  if (($rdummy ne 'con_lost') && ($roledef ne '')) {  
     my ($syspriv,$dompriv,$coursepriv)=  
  split(/\_/,$roledef);  
     if (defined($syspriv)) {  
  $allroles{'cm./'}.=':'.$syspriv;  
  $allroles{$spec.'./'}.=':'.$syspriv;  
     }  
     if ($tdomain ne '') {  
  if (defined($dompriv)) {  
     $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;  
     $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;  
  }  
  if ($trest ne '') {  
     if (defined($coursepriv)) {  
  $allroles{'cm.'.$area}.=':'.$coursepriv;  
  $allroles{$spec.'.'.$area}.=':'.$coursepriv;  
     }  
  }  
     }  
  }  
     }  
  } else {   } else {
     if (defined($pr{$trole.':s'})) {                      &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
  $allroles{'cm./'}.=':'.$pr{$trole.':s'};  
  $allroles{$spec.'./'}.=':'.$pr{$trole.':s'};  
     }  
     if ($tdomain ne '') {  
  if (defined($pr{$trole.':d'})) {  
     $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};  
     $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};  
  }  
  if ($trest ne '') {  
     if (defined($pr{$trole.':c'})) {  
  $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};  
  $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};  
     }  
  }  
     }  
  }   }
             }              }
           }             } 
         }          }
         my $adv=0;          my ($author,$adv) = &set_userprivs(\$userroles,\%allroles);
         my $author=0;  
         foreach (keys %allroles) {  
             %thesepriv=();  
             if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }  
             if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }  
             foreach (split(/:/,$allroles{$_})) {  
                 if ($_ ne '') {  
     my ($privilege,$restrictions)=split(/&/,$_);  
                     if ($restrictions eq '') {  
  $thesepriv{$privilege}='F';  
                     } else {  
                         if ($thesepriv{$privilege} ne 'F') {  
     $thesepriv{$privilege}.=$restrictions;  
                         }  
                     }  
                 }  
             }  
             $thesestr='';  
             foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }  
             $userroles.='user.priv.'.$_.'='.$thesestr."\n";  
         }  
         $userroles.='user.adv='.$adv."\n".          $userroles.='user.adv='.$adv."\n".
             'user.author='.$author."\n";              'user.author='.$author."\n";
         $ENV{'user.adv'}=$adv;          $ENV{'user.adv'}=$adv;
Line 2541  sub rolesinit { Line 2418  sub rolesinit {
     return $userroles;        return $userroles;  
 }  }
   
   sub set_arearole {
       my ($trole,$area,$tstart,$tend,$domain,$username) = @_;
   # log the associated role with the area
       &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
       return 'user.role.'.$trole.'.'.$area.'='.$tstart.'.'.$tend."\n";
   }
   
   sub custom_roleprivs {
       my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
       my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
       my $homsvr=homeserver($rauthor,$rdomain);
       if ($hostname{$homsvr} ne '') {
           my ($rdummy,$roledef)=
               &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
           if (($rdummy ne 'con_lost') && ($roledef ne '')) {
               my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef);
               if (defined($syspriv)) {
                   $$allroles{'cm./'}.=':'.$syspriv;
                   $$allroles{$spec.'./'}.=':'.$syspriv;
               }
               if ($tdomain ne '') {
                   if (defined($dompriv)) {
                       $$allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
                       $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
                   }
                   if (($trest ne '') && (defined($coursepriv))) {
                       $$allroles{'cm.'.$area}.=':'.$coursepriv;
                       $$allroles{$spec.'.'.$area}.=':'.$coursepriv;
                   }
               }
           }
       }
   }
   
   
   sub standard_roleprivs {
       my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;
       if (defined($pr{$trole.':s'})) {
           $$allroles{'cm./'}.=':'.$pr{$trole.':s'};
           $$allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
       }
       if ($tdomain ne '') {
           if (defined($pr{$trole.':d'})) {
               $$allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
               $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
           }
           if (($trest ne '') && (defined($pr{$trole.':c'}))) {
               $$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
               $$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
           }
       }
   }
   
   sub set_userprivs {
       my ($userroles,$allroles) = @_; 
       my $author=0;
       my $adv=0;
       foreach (keys %{$allroles}) {
           my %thesepriv=();
           if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
           foreach (split(/:/,$$allroles{$_})) {
               if ($_ ne '') {
                   my ($privilege,$restrictions)=split(/&/,$_);
                   if ($restrictions eq '') {
                       $thesepriv{$privilege}='F';
                   } elsif ($thesepriv{$privilege} ne 'F') {
                       $thesepriv{$privilege}.=$restrictions;
                   }
                   if ($thesepriv{'adv'} eq 'F') { $adv=1; }
               }
           }
           my $thesestr='';
           foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }
           $$userroles.='user.priv.'.$_.'='.$thesestr."\n";
       }
       return ($author,$adv);
   }
   
 # --------------------------------------------------------------- get interface  # --------------------------------------------------------------- get interface
   
 sub get {  sub get {
Line 2562  sub get { Line 2517  sub get {
    my %returnhash=();     my %returnhash=();
    my $i=0;     my $i=0;
    foreach (@$storearr) {     foreach (@$storearr) {
       $returnhash{$_}=unescape($pairs[$i]);        $returnhash{$_}=&thaw_unescape($pairs[$i]);
       $i++;        $i++;
    }     }
    return %returnhash;     return %returnhash;
Line 2601  sub dump { Line 2556  sub dump {
    my %returnhash=();     my %returnhash=();
    foreach (@pairs) {     foreach (@pairs) {
       my ($key,$value)=split(/=/,$_);        my ($key,$value)=split(/=/,$_);
       $returnhash{unescape($key)}=unescape($value);        $returnhash{unescape($key)}=&thaw_unescape($value);
    }     }
    return %returnhash;     return %returnhash;
 }  }
Line 2647  sub currentdump { Line 2602  sub currentdump {
            my ($key,$value)=split(/=/,$_);             my ($key,$value)=split(/=/,$_);
            my ($symb,$param) = split(/:/,$key);             my ($symb,$param) = split(/:/,$key);
            $returnhash{&unescape($symb)}->{&unescape($param)} =              $returnhash{&unescape($symb)}->{&unescape($param)} = 
                                                           &unescape($value);                                                          &thaw_unescape($value);
        }         }
    }     }
    return %returnhash;     return %returnhash;
Line 2713  sub put { Line 2668  sub put {
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
    my $items='';     my $items='';
    foreach (keys %$storehash) {     foreach (keys %$storehash) {
        $items.=&escape($_).'='.&escape($$storehash{$_}).'&';         $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
    }     }
    $items=~s/\&$//;     $items=~s/\&$//;
    return &reply("put:$udomain:$uname:$namespace:$items",$uhome);     return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
Line 2752  sub cput { Line 2707  sub cput {
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
    my $items='';     my $items='';
    foreach (keys %$storehash) {     foreach (keys %$storehash) {
        $items.=escape($_).'='.escape($$storehash{$_}).'&';         $items.=escape($_).'='.&freeze_escape($$storehash{$_}).'&';
    }     }
    $items=~s/\&$//;     $items=~s/\&$//;
    return &critical("put:$udomain:$uname:$namespace:$items",$uhome);     return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
Line 2775  sub eget { Line 2730  sub eget {
    my %returnhash=();     my %returnhash=();
    my $i=0;     my $i=0;
    foreach (@$storearr) {     foreach (@$storearr) {
       $returnhash{$_}=unescape($pairs[$i]);        $returnhash{$_}=&thaw_unescape($pairs[$i]);
       $i++;        $i++;
    }     }
    return %returnhash;     return %returnhash;
Line 2833  sub allowed { Line 2788  sub allowed {
     }      }
   
 # Free bre access to user's own portfolio contents  # Free bre access to user's own portfolio contents
     $uri=~m:([^/]+)/([^/]+)/([^/]+)/([^/]+)/:;      my ($space,$domain,$name,$dir)=split('/',$uri);
     if (('uploaded' eq $1)&&($ENV{'user.name'} eq $3) && ($ENV{'user.domain'} eq $2) && ('portfolio' eq $4)) {      if (('uploaded' eq $space) && ($ENV{'user.name'} eq $name) && 
    ($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {
         return 'F';          return 'F';
     }      }
   
 # Free bre to public access  # Free bre to public access
   
     if ($priv eq 'bre') {      if ($priv eq 'bre') {
         my $copyright=&metadata($uri,'copyright');          my $copyright=&metadata($uri,'copyright');
  if (($copyright eq 'public') && (!$ENV{'request.course.id'})) {    if (($copyright eq 'public') && (!$ENV{'request.course.id'})) { 
Line 3238  sub log_query { Line 3195  sub log_query {
 sub fetch_enrollment_query {  sub fetch_enrollment_query {
     my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;      my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
     my $homeserver;      my $homeserver;
       my $maxtries = 1;
     if ($context eq 'automated') {      if ($context eq 'automated') {
         $homeserver = $perlvar{'lonHostID'};          $homeserver = $perlvar{'lonHostID'};
           $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
     } else {      } else {
         $homeserver = &homeserver($cnum,$dom);          $homeserver = &homeserver($cnum,$dom);
     }      }
Line 3257  sub fetch_enrollment_query { Line 3216  sub fetch_enrollment_query {
         return 'error: '.$queryid;          return 'error: '.$queryid;
     }      }
     my $reply = &get_query_reply($queryid);      my $reply = &get_query_reply($queryid);
       my $tries = 1;
       while (($reply=~/^timeout/) && ($tries < $maxtries)) {
           $reply = &get_query_reply($queryid);
           $tries ++;
       }
     if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {      if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
         &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum);          &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
     } else {      } else {
         my @responses = split/:/,$reply;          my @responses = split/:/,$reply;
         if ($homeserver eq $perlvar{'lonHostID'}) {          if ($homeserver eq $perlvar{'lonHostID'}) {
Line 3665  sub modify_student_enrollment { Line 3629  sub modify_student_enrollment {
         $gene   = $tmp{'generation'} if (!defined($gene)   || $gene eq '');          $gene   = $tmp{'generation'} if (!defined($gene)   || $gene eq '');
         $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');          $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');
     }      }
     my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,      my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
                                                            $first,$middle);  
     my $reply=cput('classlist',      my $reply=cput('classlist',
    {"$uname:$udom" =>      {"$uname:$udom" => 
  join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },   join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
Line 3683  sub modify_student_enrollment { Line 3646  sub modify_student_enrollment {
     return &assignrole($udom,$uname,$uurl,'st',$end,$start);      return &assignrole($udom,$uname,$uurl,'st',$end,$start);
 }  }
   
   sub format_name {
       my ($firstname,$middlename,$lastname,$generation,$first)=@_;
       my $name;
       if ($first ne 'lastname') {
    $name=$firstname.' '.$middlename.' '.$lastname.' '.$generation;
       } else {
    if ($lastname=~/\S/) {
       $name.= $lastname.' '.$generation.', '.$firstname.' '.$middlename;
       $name=~s/\s+,/,/;
    } else {
       $name.= $firstname.' '.$middlename.' '.$generation;
    }
       }
       $name=~s/^\s+//;
       $name=~s/\s+$//;
       $name=~s/\s+/ /g;
       return $name;
   }
   
 # ------------------------------------------------- Write to course preferences  # ------------------------------------------------- Write to course preferences
   
 sub writecoursepref {  sub writecoursepref {
Line 3801  sub diskusage { Line 3783  sub diskusage {
     return $listing;      return $listing;
 }  }
   
   sub is_locked {
       my ($file_name, $domain, $user) = @_;
       my @check;
       my $is_locked;
       push @check, $file_name;
       my %locked = &Apache::lonnet::get('file_permissions',\@check,
                                           $ENV{'user.domain'},$ENV{'user.name'});
       if (ref($locked{$file_name}) eq 'ARRAY') {
           $is_locked = 'true';
       } else {
           $is_locked = 'false';
       }
   }
   
   # ------------------------------------------------------------- Mark as Read Only
   
   sub mark_as_readonly {
       my ($domain,$user,$files,$what) = @_;
       my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
       foreach my $file (@{$files}) {
           push(@{$current_permissions{$file}},$what);
       }
       &Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user);
       return;
   }
   
   #--------------------------------------------------------------Get Marked as Read Only
   
   sub get_marked_as_readonly {
       my ($domain,$user,$what) = @_;
       my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
       my @readonly_files;
       while (my ($file_name,$value) = each(%current_permissions)) {
           if (ref($value) eq "ARRAY"){
               foreach my $stored_what (@{$value}) {
                   if ($stored_what eq $what) {
                       push(@readonly_files, $file_name);
                   } elsif (!defined($what)) {
                       push(@readonly_files, $file_name);
                   }
               }
           } 
       }
       return @readonly_files;
   }
   
   # ------------------------------------------------------------ Unmark as Read Only
   
   sub unmark_as_readonly {
       # unmarks all files locked by $what 
       # for portfolio submissions, $what contains $crsid and $symb
       my ($domain,$user,$what) = @_;
       my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
       my @readonly_files = &Apache::lonnet::get_marked_as_readonly($domain,$user,$what);
       foreach my $file(@readonly_files){
           my $current_locks = $current_permissions{$file};
           my @new_locks;
           my @del_keys;
           if (ref($current_locks) eq "ARRAY"){
               foreach my $locker (@{$current_locks}) {
                   unless ($locker eq $what) {
                       push(@new_locks, $what);
                   }
               }
               if (@new_locks > 0) {
                   $current_permissions{$file} = \@new_locks;
               } else {
                   push(@del_keys, $file);
                   &Apache::lonnet::del('file_permissions',\@del_keys, $domain, $user);
                   delete $current_permissions{$file};
               }
           }
       }
       &Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user);
       return;
   }
   
 # ------------------------------------------------------------ Directory lister  # ------------------------------------------------------------ Directory lister
   
Line 3910  sub GetFileTimestamp { Line 3968  sub GetFileTimestamp {
   
 sub directcondval {  sub directcondval {
     my $number=shift;      my $number=shift;
       if (!defined($ENV{'user.state.'.$ENV{'request.course.id'}})) {
    &Apache::lonuserstate::evalstate();
       }
     if ($ENV{'user.state.'.$ENV{'request.course.id'}}) {      if ($ENV{'user.state.'.$ENV{'request.course.id'}}) {
        return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1);         return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1);
     } else {      } else {
Line 4154  sub EXT { Line 4215  sub EXT {
  $section=$ENV{'request.course.sec'};   $section=$ENV{'request.course.sec'};
     } else {      } else {
  if (! defined($usection)) {   if (! defined($usection)) {
     $section=&usection($udom,$uname,$courseid);      $section=&getsection($udom,$uname,$courseid);
  } else {   } else {
     $section = $usection;      $section = $usection;
  }   }
Line 4304  sub add_prefix_and_part { Line 4365  sub add_prefix_and_part {
   
 # ---------------------------------------------------------------- Get metadata  # ---------------------------------------------------------------- Get metadata
   
 my %metaentry;  
 sub metadata {  sub metadata {
     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;      my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
     $uri=&declutter($uri);      $uri=&declutter($uri);
Line 4324  sub metadata { Line 4384  sub metadata {
 # Everything is cached by the main uri, libraries are never directly cached  # Everything is cached by the main uri, libraries are never directly cached
 #  #
     if (!defined($liburi)) {      if (!defined($liburi)) {
  my ($result,$cached)=&is_cached_new($metacache,'meta',$uri);   my ($result,$cached)=&is_cached(\%metacache,$uri,'meta');
  if (defined($cached)) { return $result->{':'.$what}; }   if (defined($cached)) { return $result->{':'.$what}; }
     }      }
     {      {
 #  #
 # Is this a recursive call for a library?  # Is this a recursive call for a library?
 #  #
 # if (! exists($metacache{$uri})) {   if (! exists($metacache{$uri})) {
 #    $metacache{$uri}={};      $metacache{$uri}={};
 # }   }
         if ($liburi) {          if ($liburi) {
     $liburi=&declutter($liburi);      $liburi=&declutter($liburi);
             $filename=$liburi;              $filename=$liburi;
         } else {          } else {
     &devalidate_cache_new($metacache,'meta',$uri);      &devalidate_cache(\%metacache,$uri,'meta');
     undef(%metaentry);  
  }   }
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring;   my $metastring;
  if ($uri !~ m|^uploaded/|) {   if ($uri !~ m|^uploaded/|) {
     my $file=&filelocation('',&clutter($filename));      my $file=&filelocation('',&clutter($filename));
     #push(@{$metaentry{$uri.'.file'}},$file);      push(@{$metacache{$uri.'.file'}},$file);
     $metastring=&getfile($file);      $metastring=&getfile($file);
  }   }
         my $parser=HTML::LCParser->new(\$metastring);          my $parser=HTML::LCParser->new(\$metastring);
Line 4363  sub metadata { Line 4422  sub metadata {
     if (defined($token->[2]->{'id'})) {       if (defined($token->[2]->{'id'})) { 
  $keyroot.='_'.$token->[2]->{'id'};    $keyroot.='_'.$token->[2]->{'id'}; 
     }      }
     if ($metaentry{':packages'}) {      if ($metacache{$uri}->{':packages'}) {
  $metaentry{':packages'}.=','.$package.$keyroot;   $metacache{$uri}->{':packages'}.=','.$package.$keyroot;
     } else {      } else {
  $metaentry{':packages'}=$package.$keyroot;   $metacache{$uri}->{':packages'}=$package.$keyroot;
     }      }
     foreach (keys %packagetab) {      foreach (keys %packagetab) {
  my $part=$keyroot;   my $part=$keyroot;
Line 4388  sub metadata { Line 4447  sub metadata {
     if ($subp eq 'display') {      if ($subp eq 'display') {
  $value.=' [Part: '.$part.']';   $value.=' [Part: '.$part.']';
     }      }
     $metaentry{':'.$unikey.'.part'}=$part;      $metacache{$uri}->{':'.$unikey.'.part'}=$part;
     $metathesekeys{$unikey}=1;      $metathesekeys{$unikey}=1;
     unless (defined($metaentry{':'.$unikey.'.'.$subp})) {      unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
  $metaentry{':'.$unikey.'.'.$subp}=$value;   $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
     }      }
     if (defined($metaentry{':'.$unikey.'.default'})) {      if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
  $metaentry{':'.$unikey}=   $metacache{$uri}->{':'.$unikey}=
     $metaentry{':'.$unikey.'.default'};      $metacache{$uri}->{':'.$unikey.'.default'};
     }      }
  }   }
     }      }
Line 4428  sub metadata { Line 4487  sub metadata {
     foreach (sort(split(/\,/,&metadata($uri,'keys',      foreach (sort(split(/\,/,&metadata($uri,'keys',
        $location,$unikey,         $location,$unikey,
        $depthcount+1)))) {         $depthcount+1)))) {
  $metaentry{':'.$_}=$metaentry{':'.$_};   $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
  $metathesekeys{$_}=1;   $metathesekeys{$_}=1;
     }      }
  }   }
Line 4439  sub metadata { Line 4498  sub metadata {
  }   }
  $metathesekeys{$unikey}=1;   $metathesekeys{$unikey}=1;
  foreach (@{$token->[3]}) {   foreach (@{$token->[3]}) {
     $metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_};      $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_};
  }   }
  my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));   my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
  my $default=$metaentry{':'.$unikey.'.default'};   my $default=$metacache{$uri}->{':'.$unikey.'.default'};
  if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {   if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
  # only ws inside the tag, and not in default, so use default   # only ws inside the tag, and not in default, so use default
  # as value   # as value
     $metaentry{':'.$unikey}=$default;      $metacache{$uri}->{':'.$unikey}=$default;
  } else {   } else {
   # either something interesting inside the tag or default    # either something interesting inside the tag or default
                   # uninteresting                    # uninteresting
     $metaentry{':'.$unikey}=$internaltext;      $metacache{$uri}->{':'.$unikey}=$internaltext;
  }   }
 # end of not-a-package not-a-library import  # end of not-a-package not-a-library import
     }      }
Line 4467  sub metadata { Line 4526  sub metadata {
     &metadata_create_package_def($uri,$key,'extension_'.$extension,      &metadata_create_package_def($uri,$key,'extension_'.$extension,
  \%metathesekeys);   \%metathesekeys);
  }   }
  if (!exists($metaentry{':packages'})) {   if (!exists($metacache{$uri}->{':packages'})) {
     foreach my $key (sort(keys(%packagetab))) {      foreach my $key (sort(keys(%packagetab))) {
  #no specific packages well let's get default then   #no specific packages well let's get default then
  if ($key!~/^default&/) { next; }   if ($key!~/^default&/) { next; }
Line 4476  sub metadata { Line 4535  sub metadata {
     }      }
  }   }
 # are there custom rights to evaluate  # are there custom rights to evaluate
  if ($metaentry{':copyright'} eq 'custom') {   if ($metacache{$uri}->{':copyright'} eq 'custom') {
   
     #      #
     # Importing a rights file here      # Importing a rights file here
     #      #
     unless ($depthcount) {      unless ($depthcount) {
  my $location=$metaentry{':customdistributionfile'};   my $location=$metacache{$uri}->{':customdistributionfile'};
  my $dir=$filename;   my $dir=$filename;
  $dir=~s|[^/]*$||;   $dir=~s|[^/]*$||;
  $location=&filelocation($dir,$location);   $location=&filelocation($dir,$location);
  foreach (sort(split(/\,/,&metadata($uri,'keys',   foreach (sort(split(/\,/,&metadata($uri,'keys',
    $location,'_rights',     $location,'_rights',
    $depthcount+1)))) {     $depthcount+1)))) {
     #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_};      $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
     $metathesekeys{$_}=1;      $metathesekeys{$_}=1;
  }   }
     }      }
  }   }
  $metaentry{':keys'}=join(',',keys %metathesekeys);   $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys);
  &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);   &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri);
  $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);   $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys);
  &do_cache_new($metacache,'meta',$uri,\%metaentry);   &do_cache(\%metacache,$uri,$metacache{$uri},'meta');
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metaentry{':'.$what};      return $metacache{$uri}->{':'.$what};
 }  }
   
 sub metadata_create_package_def {  sub metadata_create_package_def {
Line 4508  sub metadata_create_package_def { Line 4567  sub metadata_create_package_def {
     my ($pack,$name,$subp)=split(/\&/,$key);      my ($pack,$name,$subp)=split(/\&/,$key);
     if ($subp eq 'default') { next; }      if ($subp eq 'default') { next; }
           
     if (defined($metaentry{':packages'})) {      if (defined($metacache{$uri}->{':packages'})) {
  $metaentry{':packages'}.=','.$package;   $metacache{$uri}->{':packages'}.=','.$package;
     } else {      } else {
  $metaentry{':packages'}=$package;   $metacache{$uri}->{':packages'}=$package;
     }      }
     my $value=$packagetab{$key};      my $value=$packagetab{$key};
     my $unikey;      my $unikey;
     $unikey='parameter_0_'.$name;      $unikey='parameter_0_'.$name;
     $metaentry{':'.$unikey.'.part'}=0;      $metacache{$uri}->{':'.$unikey.'.part'}=0;
     $$metathesekeys{$unikey}=1;      $$metathesekeys{$unikey}=1;
     unless (defined($metaentry{':'.$unikey.'.'.$subp})) {      unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
  $metaentry{':'.$unikey.'.'.$subp}=$value;   $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
     }      }
     if (defined($metaentry{':'.$unikey.'.default'})) {      if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
  $metaentry{':'.$unikey}=   $metacache{$uri}->{':'.$unikey}=
     $metaentry{':'.$unikey.'.default'};      $metacache{$uri}->{':'.$unikey.'.default'};
     }      }
 }  }
   
Line 4811  sub numval { Line 4870  sub numval {
     $txt=~tr/U-Z/0-5/;      $txt=~tr/U-Z/0-5/;
     $txt=~tr/u-z/0-5/;      $txt=~tr/u-z/0-5/;
     $txt=~s/\D//g;      $txt=~s/\D//g;
       if ($_64bit) { if ($txt > 2**32) { return -1; } }
     return int($txt);      return int($txt);
 }  }
   
Line 4826  sub numval2 { Line 4886  sub numval2 {
     my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);      my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
     my $total;      my $total;
     foreach my $val (@txts) { $total+=$val; }      foreach my $val (@txts) { $total+=$val; }
       if ($_64bit) { if ($total > 2**32) { return -1; } }
     return int($total);      return int($total);
 }  }
   
Line 4842  sub get_rand_alg { Line 4903  sub get_rand_alg {
     return &latest_rnd_algorithm_id();      return &latest_rnd_algorithm_id();
 }  }
   
   sub validCODE {
       my ($CODE)=@_;
       if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; }
       return 0;
   }
   
 sub getCODE {  sub getCODE {
     if (defined($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; }      if (&validCODE($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; }
     if (defined($Apache::lonhomework::parsing_a_problem) &&      if (defined($Apache::lonhomework::parsing_a_problem) &&
  defined($Apache::lonhomework::history{'resource.CODE'})) {   &validCODE($Apache::lonhomework::history{'resource.CODE'})) {
  return $Apache::lonhomework::history{'resource.CODE'};   return $Apache::lonhomework::history{'resource.CODE'};
     }      }
     return undef;      return undef;
Line 4887  sub rndseed_32bit { Line 4954  sub rndseed_32bit {
  my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;   my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num:$symb");   #&Apache::lonxml::debug("rndseed :$num:$symb");
    if ($_64bit) { $num=(($num<<32)>>32); }
  return $num;   return $num;
     }      }
 }  }
Line 4907  sub rndseed_64bit { Line 4975  sub rndseed_64bit {
  my $num2=$nameseed+$domainseed+$courseseed;   my $num2=$nameseed+$domainseed+$courseseed;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num:$symb");   #&Apache::lonxml::debug("rndseed :$num:$symb");
    if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
    if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
  return "$num1,$num2";   return "$num1,$num2";
     }      }
 }  }
Line 4950  sub rndseed_64bit3 { Line 5020  sub rndseed_64bit3 {
  my $num1=$symbchck+$symbseed+$namechck;   my $num1=$symbchck+$symbseed+$namechck;
  my $num2=$nameseed+$domainseed+$courseseed;   my $num2=$nameseed+$domainseed+$courseseed;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num:$symb");   #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit");
    if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
   
  return "$num1:$num2";   return "$num1:$num2";
     }      }
 }  }
Line 4968  sub rndseed_CODE_64bit { Line 5040  sub rndseed_CODE_64bit {
  my $num2=$CODEseed+$courseseed+$symbchck;   my $num2=$CODEseed+$courseseed+$symbchck;
  #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");   #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");   #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
    if ($_64bit) { $num1=(($num1<<32)>>32); }
    if ($_64bit) { $num2=(($num2<<32)>>32); }
  return "$num1:$num2";   return "$num1:$num2";
     }      }
 }  }
Line 5132  sub repcopy_userfile { Line 5206  sub repcopy_userfile {
   
 sub tokenwrapper {  sub tokenwrapper {
     my $uri=shift;      my $uri=shift;
     $uri=~s/^http\:\/\/([^\/]+)//;      $uri=~s|^http\://([^/]+)||;
     $uri=~s/^\///;      $uri=~s|^/||;
     $ENV{'user.environment'}=~/\/([^\/]+)\.id/;      $ENV{'user.environment'}=~/\/([^\/]+)\.id/;
     my $token=$1;      my $token=$1;
     if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {      my (undef,$udom,$uname,$file)=split('/',$uri,4);
         &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});      if ($udom && $uname && $file) {
         return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.   $file=~s|(\?\.*)*$||;
           &appenv("userfile.$udom/$uname/$file" => $ENV{'request.course.id'});
           return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri.
                (($uri=~/\?/)?'&':'?').'token='.$token.                 (($uri=~/\?/)?'&':'?').'token='.$token.
                                '&tokenissued='.$perlvar{'lonHostID'};                                 '&tokenissued='.$perlvar{'lonHostID'};
     } else {      } else {
Line 5271  sub clutter { Line 5347  sub clutter {
     return $thisfn;      return $thisfn;
 }  }
   
   sub freeze_escape {
       my ($value)=@_;
       if (ref($value)) {
    $value=&nfreeze($value);
    return '__FROZEN__'.&escape($value);
       }
       return &escape($value);
   }
   
 # -------------------------------------------------------- Escape Special Chars  # -------------------------------------------------------- Escape Special Chars
   
 sub escape {  sub escape {
Line 5287  sub unescape { Line 5372  sub unescape {
     return $str;      return $str;
 }  }
   
   sub thaw_unescape {
       my ($value)=@_;
       if ($value =~ /^__FROZEN__/) {
    substr($value,0,10,undef);
    $value=&unescape($value);
    return &thaw($value);
       }
       return &unescape($value);
   }
   
 sub mod_perl_version {  sub mod_perl_version {
     if (defined($perlvar{'MODPERL2'})) {      if (defined($perlvar{'MODPERL2'})) {
  return 2;   return 2;
Line 5306  sub goodbye { Line 5401  sub goodbye {
 #not converted to using infrastruture and probably shouldn't be  #not converted to using infrastruture and probably shouldn't be
    &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));     &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));
 #converted  #converted
 #   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));     &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
    &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache)));     &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache)));
    &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache)));     &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache)));
    &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));     &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));
 #1.1 only  #1.1 only
    &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));     &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));
    &logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache)));     &logthis(sprintf("%-20s is %s",'%getsectioncache',scalar(%getsectioncache)));
    &logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));     &logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));
    &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache)));     &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache)));
    &flushcourselogs();     &flushcourselogs();
Line 5459  BEGIN { Line 5554  BEGIN {
   
 }  }
   
 $metacache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']});  %metacache=();
   
 $processmarker='_'.time.'_'.$perlvar{'lonHostID'};  $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
 $dumpcount=0;  $dumpcount=0;
Line 5467  $dumpcount=0; Line 5562  $dumpcount=0;
 &logtouch();  &logtouch();
 &logthis('<font color=yellow>INFO: Read configuration</font>');  &logthis('<font color=yellow>INFO: Read configuration</font>');
 $readit=1;  $readit=1;
       {
    use integer;
    my $test=(2**32)+1;
    if ($test != 0) { $_64bit=1; }
    &logthis(" Detected 64bit platform ($_64bit)");
       }
 }  }
 }  }
   
Line 5694  X<rolesinit()> Line 5795  X<rolesinit()>
 B<rolesinit($udom,$username,$authhost)>: get user privileges  B<rolesinit($udom,$username,$authhost)>: get user privileges
   
 =item *  =item *
 X<usection()>  X<getsection()>
 B<usection($udom,$uname,$cname)>: finds the section of student in the  B<getsection($udom,$uname,$cname)>: finds the section of student in the
 course $cname, return section name/number or '' for "not in course"  course $cname, return section name/number or '' for "not in course"
 and '-1' for "no section"  and '-1' for "no section"
   
Removed from v.1.545.2.2  
changed lines
  Added in v.1.567

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