[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.1 and 1.558

version 1.545.2.1, 2004/09/22 18:31:12 version 1.558, 2004/11/02 23:22:47
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);
   
 use IO::Socket;  use IO::Socket;
Line 47  use GDBM_File; Line 47  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 117  sub logperm { Line 116  sub logperm {
 sub subreply {  sub subreply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     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);
       }
       # 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 435  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 772  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 796  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 874  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 1009  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($name.':'.$id);  
 }  
   
 my $lastone;  
 my $lastname;  
 sub is_cached_new {  
     my ($cache,$name,$id,$debug) = @_;  
     $debug=0;  
     $id=$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=$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 1920  sub devalidate { Line 1872  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 1934  sub devalidate { Line 1887  sub devalidate {
                     $uname.' at '.$udom.' for '.                      $uname.' at '.$udom.' for '.
     $symb.': '.$status);      $symb.': '.$status);
         }          }
    &delenv('user.state.'.$cid);
     }      }
 }  }
   
Line 2253  sub tmprestore { Line 2207  sub tmprestore {
 }  }
   
 # ----------------------------------------------------------------------- Store  # ----------------------------------------------------------------------- Store
 my $memcache_store=0;  
 sub store {  sub store {
     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;      my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
     my $home='';      my $home='';
Line 2267  sub store { Line 2221  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);
     $memcache_store &&  
  $metacache->delete("store:".$symb.":".$stuname.":".$domain.':'.$namespace);  
     if (!$namespace) {       if (!$namespace) { 
        unless ($namespace=$ENV{'request.course.id'}) {          unless ($namespace=$ENV{'request.course.id'}) { 
           return '';             return ''; 
Line 2304  sub cstore { Line 2257  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);
     $memcache_store &&  
  $metacache->delete("store:".$symb.":".$stuname.":".$domain.':'.$namespace);  
     if (!$namespace) {       if (!$namespace) { 
        unless ($namespace=$ENV{'request.course.id'}) {          unless ($namespace=$ENV{'request.course.id'}) { 
           return '';             return ''; 
Line 2348  sub restore { Line 2300  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'}; }
     if ($memcache_store) {  
  my $rethash=$metacache->get("store:".$symb.":".$stuname.":".  
     $domain.':'.$namespace);  
  if ($rethash) { return %{$rethash}; }  
     }  
     my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");      my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
   
     my %returnhash=();      my %returnhash=();
Line 2366  sub restore { Line 2313  sub restore {
           $returnhash{$_}=$returnhash{$version.':'.$_};            $returnhash{$_}=$returnhash{$version.':'.$_};
        }         }
     }      }
     if ($memcache_store) {  
  $metacache->set("store:".$symb.":".$stuname.":".$domain.':'.$namespace,  
  \%returnhash);  
     }  
     return %returnhash;      return %returnhash;
 }  }
   
Line 2526  sub rolesinit { Line 2469  sub rolesinit {
         my $author=0;          my $author=0;
         foreach (keys %allroles) {          foreach (keys %allroles) {
             %thesepriv=();              %thesepriv=();
             if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }  
             if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }              if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
             foreach (split(/:/,$allroles{$_})) {              foreach (split(/:/,$allroles{$_})) {
                 if ($_ ne '') {                  if ($_ ne '') {
Line 2538  sub rolesinit { Line 2480  sub rolesinit {
     $thesepriv{$privilege}.=$restrictions;      $thesepriv{$privilege}.=$restrictions;
                         }                          }
                     }                      }
       if ($thesepriv{'adv'} eq 'F') { $adv=1; }
                 }                  }
             }              }
             $thesestr='';              $thesestr='';
Line 2572  sub get { Line 2515  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 2611  sub dump { Line 2554  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 2657  sub currentdump { Line 2600  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 2723  sub put { Line 2666  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 2762  sub cput { Line 2705  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 2785  sub eget { Line 2728  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 2843  sub allowed { Line 2786  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';
     }      }
   
Line 3249  sub log_query { Line 3193  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 3268  sub fetch_enrollment_query { Line 3214  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 3676  sub modify_student_enrollment { Line 3627  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 3694  sub modify_student_enrollment { Line 3644  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 3921  sub GetFileTimestamp { Line 3890  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 4165  sub EXT { Line 4137  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 4315  sub add_prefix_and_part { Line 4287  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 4335  sub metadata { Line 4306  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 4374  sub metadata { Line 4344  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 4399  sub metadata { Line 4369  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 4439  sub metadata { Line 4409  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 4450  sub metadata { Line 4420  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 4478  sub metadata { Line 4448  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 4487  sub metadata { Line 4457  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 4519  sub metadata_create_package_def { Line 4489  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 5143  sub repcopy_userfile { Line 5113  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 5282  sub clutter { Line 5254  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 5298  sub unescape { Line 5279  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 5317  sub goodbye { Line 5308  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 5470  BEGIN { Line 5461  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 5705  X<rolesinit()> Line 5696  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.1  
changed lines
  Added in v.1.558

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