[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.484 and 1.559

version 1.484, 2004/04/01 15:24:44 version 1.559, 2004/11/03 00:11:42
Line 32  package Apache::lonnet; Line 32  package Apache::lonnet;
 use strict;  use strict;
 use LWP::UserAgent();  use LWP::UserAgent();
 use HTTP::Headers;  use HTTP::Headers;
 use Date::Parse;  use HTTP::Date;
   # 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 %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 46  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();  use Time::HiRes qw( gettimeofday tv_interval );
 my $readit;  my $readit;
   my $max_connection_retries = 10;     # Or some such value.
   
 =pod  =pod
   
Line 115  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 616  sub idput { Line 643  sub idput {
     my ($udom,%ids)=@_;      my ($udom,%ids)=@_;
     my %servers=();      my %servers=();
     foreach (keys %ids) {      foreach (keys %ids) {
    &cput('environment',{'id'=>$ids{$_}},$udom,$_);
         my $uhom=&homeserver($_,$udom);          my $uhom=&homeserver($_,$udom);
         if ($uhom ne 'no_host') {          if ($uhom ne 'no_host') {
             my $id=&escape($ids{$_});              my $id=&escape($ids{$_});
Line 626  sub idput { Line 654  sub idput {
             } else {              } else {
                 $servers{$uhom}=$id.'='.$unam;                  $servers{$uhom}=$id.'='.$unam;
             }              }
             &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom);  
         }          }
     }      }
     foreach (keys %servers) {      foreach (keys %servers) {
Line 641  sub assign_access_key { Line 668  sub assign_access_key {
 # a valid key looks like uname:udom#comments  # a valid key looks like uname:udom#comments
 # comments are being appended  # comments are being appended
 #  #
     my ($ckey,$cdom,$cnum,$udom,$uname,$logentry)=@_;      my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_;
       $kdom=
      $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($kdom));
       $knum=
      $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($knum));
     $cdom=      $cdom=
    $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));     $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
     $cnum=      $cnum=
    $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));     $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
     $udom=$ENV{'user.name'} unless (defined($udom));      $udom=$ENV{'user.name'} unless (defined($udom));
     $uname=$ENV{'user.domain'} unless (defined($uname));      $uname=$ENV{'user.domain'} unless (defined($uname));
     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);      my %existing=&get('accesskeys',[$ckey],$kdom,$knum);
     if (($existing{$ckey}=~/^\#(.*)$/) || # - new key      if (($existing{$ckey}=~/^\#(.*)$/) || # - new key
         ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) {           ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) { 
                                                   # assigned to this person                                                    # assigned to this person
Line 657  sub assign_access_key { Line 688  sub assign_access_key {
                                                   # the first time around                                                    # the first time around
 # ready to assign  # ready to assign
         $logentry=$1.'; '.$logentry;          $logentry=$1.'; '.$logentry;
         if (&put('accesskey',{$ckey=>$uname.':'.$udom.'#'.$logentry},          if (&put('accesskeys',{$ckey=>$uname.':'.$udom.'#'.$logentry},
                                                  $cdom,$cnum) eq 'ok') {                                                   $kdom,$knum) eq 'ok') {
 # key now belongs to user  # key now belongs to user
     my $envkey='key.'.$cdom.'_'.$cnum;      my $envkey='key.'.$cdom.'_'.$cnum;
             if (&put('environment',{$envkey => $ckey}) eq 'ok') {              if (&put('environment',{$envkey => $ckey}) eq 'ok') {
Line 754  sub validate_access_key { Line 785  sub validate_access_key {
    $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));     $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
     $cnum=      $cnum=
    $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));     $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
     $udom=$ENV{'user.name'} unless (defined($udom));      $udom=$ENV{'user.domain'} unless (defined($udom));
     $uname=$ENV{'user.domain'} unless (defined($uname));      $uname=$ENV{'user.name'} unless (defined($uname));
     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);      my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
     return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);      return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);
 }  }
Line 766  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 790  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 821  my $disk_caching_disabled=1; Line 857  my $disk_caching_disabled=1;
 sub devalidate_cache {  sub devalidate_cache {
     my ($cache,$id,$name) = @_;      my ($cache,$id,$name) = @_;
     delete $$cache{$id.'.time'};      delete $$cache{$id.'.time'};
       delete $$cache{$id.'.file'};
     delete $$cache{$id};      delete $$cache{$id};
     if ($disk_caching_disabled) { return; }      if (1 || $disk_caching_disabled) { return; }
     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";      my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
     open(DB,"$filename.lock");      if (!-e $filename) { return; }
       open(DB,">$filename.lock");
     flock(DB,LOCK_EX);      flock(DB,LOCK_EX);
     my %hash;      my %hash;
     if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {      if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
Line 851  sub is_cached { Line 889  sub is_cached {
     my ($cache,$id,$name,$time) = @_;      my ($cache,$id,$name,$time) = @_;
     if (!$time) { $time=300; }      if (!$time) { $time=300; }
     if (!exists($$cache{$id.'.time'})) {      if (!exists($$cache{$id.'.time'})) {
  &load_cache_item($cache,$name,$id);   &load_cache_item($cache,$name,$id,$time);
     }      }
     if (!exists($$cache{$id.'.time'})) {      if (!exists($$cache{$id.'.time'})) {
 # &logthis("Didn't find $id");  # &logthis("Didn't find $id");
  return (undef,undef);   return (undef,undef);
     } else {      } else {
  if (time-($$cache{$id.'.time'})>$time) {   if (time-($$cache{$id.'.time'})>$time) {
 #    &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));      if (exists($$cache{$id.'.file'})) {
     &devalidate_cache($cache,$id,$name);   foreach my $filename (@{ $$cache{$id.'.file'} }) {
     return (undef,undef);      my $mtime=(stat($filename))[9];
       #+1 is to take care of edge effects
       if ($mtime && (($mtime+1) < ($$cache{$id.'.time'}))) {
   # &logthis("Upping $mtime - ".$$cache{$id.'.time'}.
   # "$id because of $filename");
       } else {
    &logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'})));
    &devalidate_cache($cache,$id,$name);
    return (undef,undef);
       }
    }
    $$cache{$id.'.time'}=time;
       } else {
   # &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));
    &devalidate_cache($cache,$id,$name);
    return (undef,undef);
       }
  }   }
     }      }
     return ($$cache{$id},1);      return ($$cache{$id},1);
Line 876  sub do_cache { Line 930  sub do_cache {
     $$cache{$id};      $$cache{$id};
 }  }
   
   my %do_save_item;
   my %do_save;
 sub save_cache_item {  sub save_cache_item {
     my ($cache,$name,$id)=@_;      my ($cache,$name,$id)=@_;
     if ($disk_caching_disabled) { return; }      if ($disk_caching_disabled) { return; }
     my $starttime=&Time::HiRes::time();      $do_save{$name}=$cache;
 #    &logthis("Saving :$name:$id");      if (!exists($do_save_item{$name})) { $do_save_item{$name}={} }
     my %hash;      $do_save_item{$name}->{$id}=1;
     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";      return;
     open(DB,"$filename.lock");  }
     flock(DB,LOCK_EX);  
     if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {  sub save_cache {
  eval <<'EVALBLOCK';      if ($disk_caching_disabled) { return; }
     $hash{$id.'.time'}=$$cache{$id.'.time'};      my ($cache,$name,$id);
     $hash{$id}=freeze({'item'=>$$cache{$id}});      foreach $name (keys(%do_save)) {
    $cache=$do_save{$name};
   
    my $starttime=&Time::HiRes::time();
    &logthis("Saving :$name:");
    my %hash;
    my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
    open(DB,">$filename.lock");
    flock(DB,LOCK_EX);
    if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
       foreach $id (keys(%{ $do_save_item{$name} })) {
    eval <<'EVALBLOCK';
    $hash{$id.'.time'}=$$cache{$id.'.time'};
    $hash{$id}=freeze({'item'=>$$cache{$id}});
    if (exists($$cache{$id.'.file'})) {
       $hash{$id.'.file'}=freeze({'item'=>$$cache{$id.'.file'}});
    }
 EVALBLOCK  EVALBLOCK
         if ($@) {                  if ($@) {
     &logthis("<font color='red'>save_cache blew up :$@:$name</font>");      &logthis("<font color='red'>save_cache blew up :$@:$name</font>");
     unlink($filename);      unlink($filename);
  }      last;
     } else {   }
  if (-e $filename) {      }
     &logthis("Unable to tie hash (save cache item): $name ($!)");   } else {
     unlink($filename);      if (-e $filename) {
    &logthis("Unable to tie hash (save cache): $name ($!)");
    unlink($filename);
       }
  }   }
    untie(%hash);
    flock(DB,LOCK_UN);
    close(DB);
    &logthis("save_cache $name took ".(&Time::HiRes::time()-$starttime));
     }      }
     untie(%hash);      undef(%do_save);
     flock(DB,LOCK_UN);      undef(%do_save_item);
     close(DB);  
 #    &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime));  
 }  }
   
 sub load_cache_item {  sub load_cache_item {
     my ($cache,$name,$id)=@_;      my ($cache,$name,$id,$time)=@_;
     if ($disk_caching_disabled) { return; }      if ($disk_caching_disabled) { return; }
     my $starttime=&Time::HiRes::time();      my $starttime=&Time::HiRes::time();
 #    &logthis("Before Loading $name  for $id size is ".scalar(%$cache));  #    &logthis("Before Loading $name  for $id size is ".scalar(%$cache));
     my %hash;      my %hash;
     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";      my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
     open(DB,"$filename.lock");      if (!-e $filename) { return; }
       open(DB,">$filename.lock");
     flock(DB,LOCK_SH);      flock(DB,LOCK_SH);
     if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {      if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {
  eval <<'EVALBLOCK';   eval <<'EVALBLOCK';
Line 930  sub load_cache_item { Line 1009  sub load_cache_item {
  }   }
 #    &logthis("Initial load: $count");  #    &logthis("Initial load: $count");
     } else {      } else {
  my $hashref=thaw($hash{$id});   if (($$cache{$id.'.time'}+$time) < time) {
  $$cache{$id}=$hashref->{'item'};      $$cache{$id.'.time'}=$hash{$id.'.time'};
  $$cache{$id.'.time'}=$hash{$id.'.time'};      {
    my $hashref=thaw($hash{$id});
    $$cache{$id}=$hashref->{'item'};
       }
       if (exists($hash{$id.'.file'})) {
    my $hashref=thaw($hash{$id.'.file'});
    $$cache{$id.'.file'}=$hashref->{'item'};
       }
    }
     }      }
 EVALBLOCK  EVALBLOCK
         if ($@) {          if ($@) {
Line 952  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 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 1042  sub currentversion { Line 1097  sub currentversion {
 sub subscribe {  sub subscribe {
     my $fname=shift;      my $fname=shift;
     if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }      if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }
       $fname=~s/[\n\r]//g;
     my $author=$fname;      my $author=$fname;
     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;      $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
     my ($udom,$uname)=split(/\//,$author);      my ($udom,$uname)=split(/\//,$author);
Line 1061  sub subscribe { Line 1117  sub subscribe {
 sub repcopy {  sub repcopy {
     my $filename=shift;      my $filename=shift;
     $filename=~s/\/+/\//g;      $filename=~s/\/+/\//g;
     if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; }      if ($filename=~m|^/home/httpd/html/adm/|) { return OK; }
       if ($filename=~m|^/home/httpd/html/lonUsers/|) { return OK; }
       if ($filename=~m|^/home/httpd/html/userfiles/| or
    $filename=~m|^/*uploaded/|) { 
    return &repcopy_userfile($filename);
       }
       $filename=~s/[\n\r]//g;
     my $transname="$filename.in.transfer";      my $transname="$filename.in.transfer";
     if ((-e $filename) || (-e $transname)) { return OK; }      if ((-e $filename) || (-e $transname)) { return OK; }
     my $remoteurl=subscribe($filename);      my $remoteurl=subscribe($filename);
Line 1126  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=~s/^.*?\<body[^\>]*\>//si;  
     $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;  
     $output=~      $output=~
             s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;              s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
       $output=~s/^.*?\<body[^\>]*\>//si;
       $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
     return $output;      return $output;
 }  }
   
Line 1164  sub externalssi { Line 1226  sub externalssi {
     return $response->content;      return $response->content;
 }  }
   
 # ------- Add a token to a remote URI's query string to vouch for access rights  # -------------------------------- Allow a /uploaded/ URI to be vouched for
   
 sub tokenwrapper {  sub allowuploaded {
     my $uri=shift;      my ($srcurl,$url)=@_;
     $uri=~s/^http\:\/\/([^\/]+)//;      $url=&clutter(&declutter($url));
     $uri=~s/^\///;      my $dir=$url;
     $ENV{'user.environment'}=~/\/([^\/]+)\.id/;      $dir=~s/\/[^\/]+$//;
     my $token=$1;      my %httpref=();
 #    if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {      my $httpurl=&hreflocation('',$url);
     if ($uri=~m|^uploaded/([^/]+)/([^/]+)/(.+)(\?\.*)*$|) {      $httpref{'httpref.'.$httpurl}=$srcurl;
  &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});      &Apache::lonnet::appenv(%httpref);
         return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.  
                (($uri=~/\?/)?'&':'?').'token='.$token.  
                                '&tokenissued='.$perlvar{'lonHostID'};  
     } else {  
  return '/adm/notfound.html';  
     }  
 }  }
   
 # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course  # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
 # input: action, courseID, current domain, home server for course, intended  # input: action, courseID, current domain, home server for course, intended
 #        path to file, source of file.  #        path to file, source of file.
 # output: ok if successful, diagnostic message otherwise  # output: url to file (if action was uploaddoc), 
   #         ok if successful, or diagnostic message otherwise (if action was propagate or copy)
 #  #
 # Allows directory structure to be used within lonUsers/../userfiles/ for a   # Allows directory structure to be used within lonUsers/../userfiles/ for a 
 # course.  # course.
Line 1201  sub tokenwrapper { Line 1258  sub tokenwrapper {
 #         and will then be copied to  #         and will then be copied to
 #          /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in  #          /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in
 #         course's home server.  #         course's home server.
   #
 # action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file  # action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
 #         will be retrived from $ENV{form.$source} via DOCS interface to  #         will be retrived from $ENV{form.uploaddoc} (from DOCS interface) to
 #         /home/httpd/html/userfiles/$domain/1/2/3/$course/$file  #         /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
 #         and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file  #         and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file
 #         in course's home server.  #         in course's home server.
Line 1255  sub process_coursefile { Line 1313  sub process_coursefile {
             }              }
         }          }
     }      }
     unless ( ($fetchresult eq 'ok') || ($fetchresult eq 'no source file') ) {      unless ( $fetchresult eq 'ok') {
         &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.          &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
              ' to host '.$docuhome.': '.$fetchresult);               ' to host '.$docuhome.': '.$fetchresult);
     }      }
Line 1266  sub process_coursefile { Line 1324  sub process_coursefile {
 # input: name of form element, coursedoc=1 means this is for the course  # input: name of form element, coursedoc=1 means this is for the course
 # output: url of file in userspace  # output: url of file in userspace
   
 sub userfileupload {  sub clean_filename {
     my ($formname,$coursedoc)=@_;      my ($fname)=@_;
     my $fname=$ENV{'form.'.$formname.'.filename'};  
 # Replace Windows backslashes by forward slashes  # Replace Windows backslashes by forward slashes
     $fname=~s/\\/\//g;      $fname=~s/\\/\//g;
 # Get rid of everything but the actual filename  # Get rid of everything but the actual filename
Line 1277  sub userfileupload { Line 1334  sub userfileupload {
     $fname=~s/\s+/\_/g;      $fname=~s/\s+/\_/g;
 # Replace all other weird characters by nothing  # Replace all other weird characters by nothing
     $fname=~s/[^\w\.\-]//g;      $fname=~s/[^\w\.\-]//g;
   # Replace all .\d. sequences with _\d. so they no longer look like version
   # numbers
       $fname=~s/\.(\d+)(?=\.)/_$1/g;
       return $fname;
   }
   
   sub userfileupload {
       my ($formname,$coursedoc,$subdir)=@_;
       if (!defined($subdir)) { $subdir='unknown'; }
       my $fname=$ENV{'form.'.$formname.'.filename'};
       $fname=&clean_filename($fname);
 # See if there is anything left  # See if there is anything left
     unless ($fname) { return 'error: no uploaded file'; }      unless ($fname) { return 'error: no uploaded file'; }
     chop($ENV{'form.'.$formname});      chop($ENV{'form.'.$formname});
     my $url = '';      if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently
           my $now = time;
           my $filepath = 'tmp/helprequests/'.$now;
           my @parts=split(/\//,$filepath);
           my $fullpath = $perlvar{'lonDaemons'};
           for (my $i=0;$i<@parts;$i++) {
               $fullpath .= '/'.$parts[$i];
               if ((-e $fullpath)!=1) {
                   mkdir($fullpath,0777);
               }
           }
           open(my $fh,'>'.$fullpath.'/'.$fname);
           print $fh $ENV{'form.'.$formname};
           close($fh);
           return $fullpath.'/'.$fname; 
       }
 # Create the directory if not present  # Create the directory if not present
     my $docuname='';      my $docuname='';
     my $docudom='';      my $docudom='';
     my $docuhome='';      my $docuhome='';
       $fname="$subdir/$fname";
     if ($coursedoc) {      if ($coursedoc) {
  $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};   $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};
  $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};   $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
  $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};   $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
         if ($ENV{'form.folder'} =~ m/^default/) {          if ($ENV{'form.folder'} =~ m/^default/) {
             $url = &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);              return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
         } else {          } else {
             $fname=$ENV{'form.folder'}.'/'.$fname;              $fname=$ENV{'form.folder'}.'/'.$fname;
             $url = &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname);              return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname);
         }          }
     } else {      } else {
         $docuname=$ENV{'user.name'};          $docuname=$ENV{'user.name'};
         $docudom=$ENV{'user.domain'};          $docudom=$ENV{'user.domain'};
         $docuhome=$ENV{'user.home'};          $docuhome=$ENV{'user.home'};
           return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
     }      }
     return   
         &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);  
 }  }
   
 sub finishuserfileupload {  sub finishuserfileupload {
     my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;      my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;
     my $path=$docudom.'/'.$docuname.'/';      my $path=$docudom.'/'.$docuname.'/';
     my $filepath=$perlvar{'lonDocRoot'};      my $filepath=$perlvar{'lonDocRoot'};
       my ($fnamepath,$file);
       $file=$fname;
       if ($fname=~m|/|) {
           ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|);
    $path.=$fnamepath.'/';
       }
     my @parts=split(/\//,$filepath.'/userfiles/'.$path);      my @parts=split(/\//,$filepath.'/userfiles/'.$path);
     my $count;      my $count;
     for ($count=4;$count<=$#parts;$count++) {      for ($count=4;$count<=$#parts;$count++) {
Line 1318  sub finishuserfileupload { Line 1407  sub finishuserfileupload {
     }      }
 # Save the file  # Save the file
     {      {
        open(my $fh,'>'.$filepath.'/'.$fname);   #&Apache::lonnet::logthis("Saving to $filepath $file");
          open(my $fh,'>'.$filepath.'/'.$file);
        print $fh $ENV{'form.'.$formname};         print $fh $ENV{'form.'.$formname};
        close($fh);         close($fh);
     }      }
 # Notify homeserver to grep it  # Notify homeserver to grep it
 #  #
     my $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,      my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
     $docuhome);  
     if ($fetchresult eq 'ok') {      if ($fetchresult eq 'ok') {
 #  #
 # Return the URL to it  # Return the URL to it
         return '/uploaded/'.$path.$fname;          return '/uploaded/'.$path.$file;
     } else {      } else {
         &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$fname.          &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
          ' to host '.$docuhome.': '.$fetchresult);   ': '.$fetchresult);
         return '/adm/notfound.html';          return '/adm/notfound.html';
     }          }    
 }  }
   
   sub removeuploadedurl {
       my ($url)=@_;
       my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
       return &Apache::lonnet::removeuserfile($uname,$udom,$fname);
   }
   
   sub removeuserfile {
       my ($docuname,$docudom,$fname)=@_;
       my $home=&homeserver($docuname,$docudom);
       return &reply("removeuserfile:$docudom/$docuname/$fname",$home);
   }
   
   sub mkdiruserfile {
       my ($docuname,$docudom,$dir)=@_;
       my $home=&homeserver($docuname,$docudom);
       return &reply("mkdiruserfile:".&escape("$docudom/$docuname/$dir"),$home);
   }
   
   sub renameuserfile {
       my ($docuname,$docudom,$old,$new)=@_;
       my $home=&homeserver($docuname,$docudom);
       return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'.
     &escape("$new"),$home);
   }
   
 # ------------------------------------------------------------------------- Log  # ------------------------------------------------------------------------- Log
   
 sub log {  sub log {
Line 1376  sub flushcourselogs { Line 1490  sub flushcourselogs {
         }          }
         if ($courseidbuffer{$coursehombuf{$crsid}}) {          if ($courseidbuffer{$coursehombuf{$crsid}}) {
            $courseidbuffer{$coursehombuf{$crsid}}.='&'.             $courseidbuffer{$coursehombuf{$crsid}}.='&'.
  &escape($crsid).'='.&escape($coursedescrbuf{$crsid});   &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
                            '='.&escape($courseinstcodebuf{$crsid});
         } else {          } else {
            $courseidbuffer{$coursehombuf{$crsid}}=             $courseidbuffer{$coursehombuf{$crsid}}=
  &escape($crsid).'='.&escape($coursedescrbuf{$crsid});   &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
                            '='.&escape($courseinstcodebuf{$crsid});
         }              }    
     }      }
 #  #
Line 1453  sub courselog { Line 1569  sub courselog {
        $ENV{'course.'.$ENV{'request.course.id'}.'.home'};         $ENV{'course.'.$ENV{'request.course.id'}.'.home'};
     $coursedescrbuf{$ENV{'request.course.id'}}=      $coursedescrbuf{$ENV{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.description'};         $ENV{'course.'.$ENV{'request.course.id'}.'.description'};
       $courseinstcodebuf{$ENV{'request.course.id'}}=
          $ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'};
     if (defined $courselogs{$ENV{'request.course.id'}}) {      if (defined $courselogs{$ENV{'request.course.id'}}) {
  $courselogs{$ENV{'request.course.id'}}.='&'.$what;   $courselogs{$ENV{'request.course.id'}}.='&'.$what;
     } else {      } else {
Line 1577  sub getannounce { Line 1695  sub getannounce {
  if ($announcement=~/\w/) {    if ($announcement=~/\w/) { 
     return       return 
    '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.     '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
    '<tr><td bgcolor="#FFFFFF"><pre>'.$announcement.'</pre></td></tr></table>';      '<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>'; 
  } else {   } else {
     return '';      return '';
  }   }
Line 1596  sub courseidput { Line 1714  sub courseidput {
 }  }
   
 sub courseiddump {  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter)=@_;      my ($domfilter,$descfilter,$sincefilter,$hostidflag,$hostidref)=@_;
     my %returnhash=();      my %returnhash=();
     unless ($domfilter) { $domfilter=''; }      unless ($domfilter) { $domfilter=''; }
     foreach my $tryserver (keys %libserv) {      foreach my $tryserver (keys %libserv) {
  if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {          if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) {
     foreach (      if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {
              split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.          foreach (
                    split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
        $sincefilter.':'.&escape($descfilter),         $sincefilter.':'.&escape($descfilter),
                                $tryserver))) {                                 $tryserver))) {
  my ($key,$value)=split(/\=/,$_);      my ($key,$value)=split(/\=/,$_);
                 if (($key) && ($value)) {                      if (($key) && ($value)) {
     $returnhash{&unescape($key)}=&unescape($value);          $returnhash{&unescape($key)}=$value;
                       }
                 }                  }
             }              }
   
         }          }
     }      }
     return %returnhash;      return %returnhash;
Line 1619  sub courseiddump { Line 1738  sub courseiddump {
 #  #
 # ----------------------------------------------------------- Check out an item  # ----------------------------------------------------------- Check out an item
   
   sub get_first_access {
       my ($type,$argsymb)=@_;
       my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
       if ($argsymb) { $symb=$argsymb; }
       my ($map,$id,$res)=&decode_symb($symb);
       if ($type eq 'map') { $res=$map; }
       my %times=&get('firstaccesstimes',[$res],$udom,$uname);
       return $times{$res};
   }
   
   sub set_first_access {
       my ($type)=@_;
       my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
       my ($map,$id,$res)=&decode_symb($symb);
       if ($type eq 'map') { $res=$map; }
       my $firstaccess=&get_first_access($type);
       if (!$firstaccess) {
    return &put('firstaccesstimes',{$res=>time},$udom,$uname);
       }
       return 'already_set';
   }
   
 sub checkout {  sub checkout {
     my ($symb,$tuname,$tudom,$tcrsid)=@_;      my ($symb,$tuname,$tudom,$tcrsid)=@_;
     my $now=time;      my $now=time;
Line 1731  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 1745  sub devalidate { Line 1887  sub devalidate {
                     $uname.' at '.$udom.' for '.                      $uname.' at '.$udom.' for '.
     $symb.': '.$status);      $symb.': '.$status);
         }          }
    &delenv('user.state.'.$cid);
     }      }
 }  }
   
Line 1797  sub hash2str { Line 1940  sub hash2str {
 sub hashref2str {  sub hashref2str {
   my ($hashref)=@_;    my ($hashref)=@_;
   my $result='__HASH_REF__';    my $result='__HASH_REF__';
   foreach (keys(%$hashref)) {    foreach (sort(keys(%$hashref))) {
     if (ref($_) eq 'ARRAY') {      if (ref($_) eq 'ARRAY') {
       $result.=&arrayref2str($_).'=';        $result.=&arrayref2str($_).'=';
     } elsif (ref($_) eq 'HASH') {      } elsif (ref($_) eq 'HASH') {
Line 2326  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 2338  sub rolesinit { Line 2480  sub rolesinit {
     $thesepriv{$privilege}.=$restrictions;      $thesepriv{$privilege}.=$restrictions;
                         }                          }
                     }                      }
       if ($thesepriv{'adv'} eq 'F') { $adv=1; }
                 }                  }
             }              }
             $thesestr='';              $thesestr='';
Line 2372  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 2411  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 2457  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 2523  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/\&$//;
      return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
   }
   
   # ---------------------------------------------------------- putstore interface
                                                                                        
   sub putstore {
      my ($namespace,$storehash,$udomain,$uname)=@_;
      if (!$udomain) { $udomain=$ENV{'user.domain'}; }
      if (!$uname) { $uname=$ENV{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
      my $items='';
      my %allitems = ();
      foreach (keys %$storehash) {
          if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
              my $key = $1.':keys:'.$2;
              $allitems{$key} .= $3.':';
          }
          $items.=$_.'='.&escape($$storehash{$_}).'&';
      }
      foreach (keys %allitems) {
          $allitems{$_} =~ s/\:$//;
          $items.= $_.'='.$allitems{$_}.'&';
    }     }
    $items=~s/\&$//;     $items=~s/\&$//;
    return &reply("put:$udomain:$uname:$namespace:$items",$uhome);     return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
Line 2538  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 2561  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 2608  sub allowed { Line 2775  sub allowed {
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
     $uri=&declutter($uri);      $uri=&declutter($uri);
       
       
       
     if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; }      if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; }
 # Free bre access to adm and meta resources  # Free bre access to adm and meta resources
       if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) 
     if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {   || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
  return 'F';   return 'F';
     }      }
   
   # Free bre access to user's own portfolio contents
       my ($space,$domain,$name,$dir)=split('/',$uri);
       if (('uploaded' eq $space) && ($ENV{'user.name'} eq $name) && 
    ($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {
           return 'F';
       }
   
 # Free bre to public access  # Free bre to public access
   
     if ($priv eq 'bre') {      if ($priv eq 'bre') {
Line 2681  sub allowed { Line 2857  sub allowed {
   
 # URI is an uploaded document for this course  # URI is an uploaded document for this course
   
     if (($priv eq 'bre') &&       if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
         ($uri=~/^uploaded\/$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}\/$ENV{'course.'.$ENV{'request.course.id'}.'.num'}/)) {   my $refuri=$ENV{'httpref.'.$orguri};
         return 'F';   if ($refuri) {
       if ($refuri =~ m|^/adm/|) {
    $thisallowed='F';
       }
    }
     }      }
   
 # Full access at system, domain or course-wide level? Exit.  # Full access at system, domain or course-wide level? Exit.
   
     if ($thisallowed=~/F/) {      if ($thisallowed=~/F/) {
Line 3007  sub log_query { Line 3188  sub log_query {
     return get_query_reply($queryid);      return get_query_reply($queryid);
 }  }
   
   # ------- Request retrieval of institutional classlists for course(s)
   
   sub fetch_enrollment_query {
       my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
       my $homeserver;
       my $maxtries = 1;
       if ($context eq 'automated') {
           $homeserver = $perlvar{'lonHostID'};
           $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
       } else {
           $homeserver = &homeserver($cnum,$dom);
       }
       my $host=$hostname{$homeserver};
       my $cmd = '';
       foreach (keys %{$affiliatesref}) {
           $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%';
       }
       $cmd =~ s/%%$//;
       $cmd = &escape($cmd);
       my $query = 'fetchenrollment';
       my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver);
       unless ($queryid=~/^\Q$host\E\_/) { 
           &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); 
           return 'error: '.$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/) ) {
           &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
       } else {
           my @responses = split/:/,$reply;
           if ($homeserver eq $perlvar{'lonHostID'}) {
               foreach (@responses) {
                   my ($key,$value) = split/=/,$_;
                   $$replyref{$key} = $value;
               }
           } else {
               my $pathname = $perlvar{'lonDaemons'}.'/tmp';
               foreach (@responses) {
                   my ($key,$value) = split/=/,$_;
                   $$replyref{$key} = $value;
                   if ($value > 0) {
                       foreach (@{$$affiliatesref{$key}}) {
                           my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml';
                           my $destname = $pathname.'/'.$filename;
                           my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
                           if ($xml_classlist =~ /^error/) {
                               &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
                           } else {
                               if ( open(FILE,">$destname") ) {
                                   print FILE &unescape($xml_classlist);
                                   close(FILE);
                               } else {
                                   &logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum);
                               }
                           }
                       }
                   }
               }
           }
           return 'ok';
       }
       return 'error';
   }
   
 sub get_query_reply {  sub get_query_reply {
     my $queryid=shift;      my $queryid=shift;
     my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;      my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;
Line 3051  sub userlog_query { Line 3301  sub userlog_query {
     return &log_query($uname,$udom,'userlog',%filters);      return &log_query($uname,$udom,'userlog',%filters);
 }  }
   
   #--------- Call auto-enrollment subs in localenroll.pm for homeserver for course 
   
   sub auto_run {
       my ($cnum,$cdom) = @_;
       my $homeserver = &homeserver($cnum,$cdom);
       my $response = &reply('autorun:'.$cdom,$homeserver);
       return $response;
   }
                                                                                      
   sub auto_get_sections {
       my ($cnum,$cdom,$inst_coursecode) = @_;
       my $homeserver = &homeserver($cnum,$cdom);
       my @secs = ();
       my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
       unless ($response eq 'refused') {
           @secs = split/:/,$response;
       }
       return @secs;
   }
                                                                                      
   sub auto_new_course {
       my ($cnum,$cdom,$inst_course_id,$owner) = @_;
       my $homeserver = &homeserver($cnum,$cdom);
       my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
       return $response;
   }
                                                                                      
   sub auto_validate_courseID {
       my ($cnum,$cdom,$inst_course_id) = @_;
       my $homeserver = &homeserver($cnum,$cdom);
       my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));
       return $response;
   }
                                                                                      
   sub auto_create_password {
       my ($cnum,$cdom,$authparam) = @_;
       my $homeserver = &homeserver($cnum,$cdom); 
       my $create_passwd = 0;
       my $authchk = '';
       my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
       if ($response eq 'refused') {
           $authchk = 'refused';
       } else {
           ($authparam,$create_passwd,$authchk) = split/:/,$response;
       }
       return ($authparam,$create_passwd,$authchk);
   }
   
   sub auto_instcode_format {
       my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;
       my $courses = '';
       my $homeserver;
       if ($caller eq 'global') {
           $homeserver = $perlvar{'lonHostID'};
       } else {
           $homeserver = &homeserver($caller,$codedom);
       }
       my $host=$hostname{$homeserver};
       foreach (keys %{$instcodes}) {
           $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';
       }
       chop($courses);
       my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver);
       unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
           my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response;
           %{$codes} = &str2hash($codes_str);
           @{$codetitles} = &str2array($codetitles_str);
           %{$cat_titles} = &str2hash($cat_titles_str);
           %{$cat_order} = &str2hash($cat_order_str);
           return 'ok';
       }
       return $response;
   }
   
 # ------------------------------------------------------------------ Plain Text  # ------------------------------------------------------------------ Plain Text
   
 sub plaintext {  sub plaintext {
Line 3241  sub modifyuser { Line 3565  sub modifyuser {
   
 sub modifystudent {  sub modifystudent {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,      my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
         $end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_;          $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;
     if (!$cid) {      if (!$cid) {
  unless ($cid=$ENV{'request.course.id'}) {   unless ($cid=$ENV{'request.course.id'}) {
     return 'not_in_class';      return 'not_in_class';
Line 3256  sub modifystudent { Line 3580  sub modifystudent {
     # students environment      # students environment
     $uid = undef if (!$forceid);      $uid = undef if (!$forceid);
     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,      $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
  $gene,$usec,$end,$start,$type,$cid);   $gene,$usec,$end,$start,$type,$locktype,$cid);
     return $reply;      return $reply;
 }  }
   
 sub modify_student_enrollment {  sub modify_student_enrollment {
     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,      my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;
  $cid) = @_;  
     my ($cdom,$cnum,$chome);      my ($cdom,$cnum,$chome);
     if (!$cid) {      if (!$cid) {
  unless ($cid=$ENV{'request.course.id'}) {   unless ($cid=$ENV{'request.course.id'}) {
Line 3304  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 $value=&escape($uname.':'.$udom).'='.     {"$uname:$udom" => 
  &escape(join(':',$end,$start,$uid,$usec,$fullname,$type));   join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
     my $reply=critical('put:'.$cdom.':'.$cnum.':classlist:'.$value,$chome);     $cdom,$cnum);
     unless (($reply eq 'ok') || ($reply eq 'delayed')) {      unless (($reply eq 'ok') || ($reply eq 'delayed')) {
  return 'error: '.$reply;   return 'error: '.$reply;
     }      }
Line 3321  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 3343  sub writecoursepref { Line 3685  sub writecoursepref {
 # ---------------------------------------------------------- Make/modify course  # ---------------------------------------------------------- Make/modify course
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url,$course_server,$nonstandard)=@_;      my ($udom,$description,$url,$course_server,$nonstandard,$inst_code)=@_;
     $url=&declutter($url);      $url=&declutter($url);
     my $cid='';      my $cid='';
     unless (&allowed('ccc',$udom)) {      unless (&allowed('ccc',$udom)) {
Line 3376  sub createcourse { Line 3718  sub createcourse {
  return 'error: no such course';   return 'error: no such course';
     }      }
 # ----------------------------------------------------------------- Course made  # ----------------------------------------------------------------- Course made
 # log existance  # log existence
     &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description),      &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
                  $uhome);                   '='.&escape($inst_code),$uhome);
     &flushcourselogs();      &flushcourselogs();
 # set toplevel url  # set toplevel url
     my $topurl=$url;      my $topurl=$url;
Line 3431  sub revokecustomrole { Line 3773  sub revokecustomrole {
            $deleteflag);             $deleteflag);
 }  }
   
   # ------------------------------------------------------------ Disk usage
   sub diskusage {
       my ($udom,$uname,$directoryRoot)=@_;
       $directoryRoot =~ s/\/$//;
       my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));
       return $listing;
   }
   
   # ------------------------------------------------------------- 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) {
           $current_permissions{$file}.=':'.$what.':';
       }
       &Apache::lonnet::put('file_permissions',{ 'locked_files' => %current_permissions },$domain,$user);
       return;
   }
   
   # ------------------------------------------------------------ Unmark as Read Only
   
   sub unmark_as_readonly {
       my ($domain,$user,$file,$what) = @_;
       my $current_permissions = &Apache::lonnet::get('file_permissions',$file,$domain,$user);
       $current_permissions =~ s/:$file://;
       &Apache::lonnet::put('file_permissions',{ $file => $current_permissions },$domain,$user);
       return;
   }
   
 # ------------------------------------------------------------ Directory lister  # ------------------------------------------------------------ Directory lister
   
 sub dirlist {  sub dirlist {
Line 3539  sub GetFileTimestamp { Line 3911  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 3764  sub EXT { Line 4139  sub EXT {
   
  my $section;   my $section;
  if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {   if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {
       if (!$symbparm) { $symbparm=&symbread(); }
    }
    if ($symbparm && defined($courseid) && 
       $courseid eq $ENV{'request.course.id'}) {
   
     #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;      #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
   
 # ----------------------------------------------------- Cascading lookup scheme  # ----------------------------------------------------- Cascading lookup scheme
     if (!$symbparm) { $symbparm=&symbread(); }  
     my $symbp=$symbparm;      my $symbp=$symbparm;
     my $mapp=(&decode_symb($symbp))[0];      my $mapp=(&decode_symb($symbp))[0];
   
Line 3779  sub EXT { Line 4157  sub EXT {
  ($ENV{'user.domain'} eq $udom)) {   ($ENV{'user.domain'} eq $udom)) {
  $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;
                 }   }
     }      }
   
     my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;      my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
Line 3821  sub EXT { Line 4199  sub EXT {
  $uname." at ".$udom.": ".   $uname." at ".$udom.": ".
  $tmp."</font>");   $tmp."</font>");
     } elsif ($tmp=~/error: 2 /) {      } elsif ($tmp=~/error: 2 /) {
                         &EXT_cache_set($udom,$uname);   &EXT_cache_set($udom,$uname);
     } elsif ($tmp =~ /^(con_lost|no_such_host)/) {      } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
  return $tmp;   return $tmp;
     }      }
Line 3831  sub EXT { Line 4209  sub EXT {
 # -------------------------------------------------------- second, check course  # -------------------------------------------------------- second, check course
   
     my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},      my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},
   $ENV{'course.'.$courseid.'.domain'},     $ENV{'course.'.$courseid.'.domain'},
   ($seclevelr,$seclevelm,$seclevel,     ($seclevelr,$seclevelm,$seclevel,
    $courselevelr,$courselevelm,      $courselevelr,$courselevelm,
    $courselevel));      $courselevel));
     if (defined($coursereply)) { return $coursereply; }      if (defined($coursereply)) { return $coursereply; }
   
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
Line 3934  sub metadata { Line 4312  sub metadata {
     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;      my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
     $uri=&declutter($uri);      $uri=&declutter($uri);
     # if it is a non metadata possible uri return quickly      # if it is a non metadata possible uri return quickly
     if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||      if (($uri eq '') || 
    (($uri =~ m|^/*adm/|) && 
        ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
  ($uri =~ m|home/[^/]+/public_html/|) || ($uri =~ m|^uploaded/|)) {   ($uri =~ m|home/[^/]+/public_html/|)) {
  return undef;   return undef;
     }      }
     my $filename=$uri;      my $filename=$uri;
Line 3965  sub metadata { Line 4345  sub metadata {
  }   }
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring=&getfile(&filelocation('',&clutter($filename)));   my $metastring;
    if ($uri !~ m|^uploaded/|) {
       my $file=&filelocation('',&clutter($filename));
       push(@{$metacache{$uri.'.file'}},$file);
       $metastring=&getfile($file);
    }
         my $parser=HTML::LCParser->new(\$metastring);          my $parser=HTML::LCParser->new(\$metastring);
         my $token;          my $token;
         undef %metathesekeys;          undef %metathesekeys;
Line 4081  sub metadata { Line 4466  sub metadata {
     #&logthis("extsion1 $extension $key !!");      #&logthis("extsion1 $extension $key !!");
     #no specific packages #how's our extension      #no specific packages #how's our extension
     if ($key!~/^extension_\Q$extension\E&/) { next; }      if ($key!~/^extension_\Q$extension\E&/) { next; }
     &metadata_create_pacakge_def($uri,$key,'extension_'.$extension,      &metadata_create_package_def($uri,$key,'extension_'.$extension,
  \%metathesekeys);   \%metathesekeys);
  }   }
  if (!exists($metacache{$uri}->{':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; }
  &metadata_create_pacakge_def($uri,$key,'default',   &metadata_create_package_def($uri,$key,'default',
      \%metathesekeys);       \%metathesekeys);
     }      }
  }   }
Line 4120  sub metadata { Line 4505  sub metadata {
     return $metacache{$uri}->{':'.$what};      return $metacache{$uri}->{':'.$what};
 }  }
   
 sub metadata_create_pacakge_def {  sub metadata_create_package_def {
     my ($uri,$key,$package,$metathesekeys)=@_;      my ($uri,$key,$package,$metathesekeys)=@_;
     my ($pack,$name,$subp)=split(/\&/,$key);      my ($pack,$name,$subp)=split(/\&/,$key);
     if ($subp eq 'default') { next; }      if ($subp eq 'default') { next; }
Line 4177  sub metadata_generate_part0 { Line 4562  sub metadata_generate_part0 {
 sub gettitle {  sub gettitle {
     my $urlsymb=shift;      my $urlsymb=shift;
     my $symb=&symbread($urlsymb);      my $symb=&symbread($urlsymb);
     unless ($symb) {      if ($symb) {
  unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }   my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
         return &metadata($urlsymb,'title');    if (defined($cached)) { return $result; }
     }   my ($map,$resid,$url)=&decode_symb($symb);
     my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);   my $title='';
     if (defined($cached)) { return $result; }   my %bighash;
     my ($map,$resid,$url)=&decode_symb($symb);   if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
     my $title='';   &GDBM_READER(),0640)) {
     my %bighash;      my $mapid=$bighash{'map_pc_'.&clutter($map)};
     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',      $title=$bighash{'title_'.$mapid.'.'.$resid};
                             &GDBM_READER(),0640)) {      untie %bighash;
         my $mapid=$bighash{'map_pc_'.&clutter($map)};   }
         $title=$bighash{'title_'.$mapid.'.'.$resid};   $title=~s/\&colon\;/\:/gs;
         untie %bighash;   if ($title) {
     }      return &do_cache(\%titlecache,$symb,$title,'title');
     $title=~s/\&colon\;/\:/gs;   }
     if ($title) {   $urlsymb=$url;
         return &do_cache(\%titlecache,$symb,$title,'title');      }
     } else {      my $title=&metadata($urlsymb,'title');
  return &metadata($urlsymb,'title');      if (!$title) { $title=(split('/',$urlsymb))[-1]; }    
     }      return $title;
 }  }
           
 # ------------------------------------------------- Update symbolic store links  # ------------------------------------------------- Update symbolic store links
Line 4223  sub symblist { Line 4608  sub symblist {
 # --------------------------------------------------------------- Verify a symb  # --------------------------------------------------------------- Verify a symb
   
 sub symbverify {  sub symbverify {
     my ($symb,$thisfn)=@_;      my ($symb,$thisurl)=@_;
       my $thisfn=$thisurl;
   # wrapper not part of symbs
       $thisfn=~s/^\/adm\/wrapper//;
     $thisfn=&declutter($thisfn);      $thisfn=&declutter($thisfn);
 # direct jump to resource in page or to a sequence - will construct own symbs  # direct jump to resource in page or to a sequence - will construct own symbs
     if ($thisfn=~/\.(page|sequence)$/) { return 1; }      if ($thisfn=~/\.(page|sequence)$/) { return 1; }
Line 4233  sub symbverify { Line 4621  sub symbverify {
     unless ($url eq $thisfn) { return 0; }      unless ($url eq $thisfn) { return 0; }
   
     $symb=&symbclean($symb);      $symb=&symbclean($symb);
       $thisurl=&deversion($thisurl);
     $thisfn=&deversion($thisfn);      $thisfn=&deversion($thisfn);
   
     my %bighash;      my %bighash;
Line 4240  sub symbverify { Line 4629  sub symbverify {
   
     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
         my $ids=$bighash{'ids_'.&clutter($thisfn)};          my $ids=$bighash{'ids_'.&clutter($thisurl)};
         unless ($ids) {           unless ($ids) { 
            $ids=$bighash{'ids_/'.$thisfn};             $ids=$bighash{'ids_/'.$thisurl};
         }          }
         if ($ids) {          if ($ids) {
 # ------------------------------------------------------------------- Has ID(s)  # ------------------------------------------------------------------- Has ID(s)
Line 4271  sub symbclean { Line 4660  sub symbclean {
 # remove version from URL  # remove version from URL
     $symb=~s/\.(\d+)\.(\w+)$/\.$2/;      $symb=~s/\.(\d+)\.(\w+)$/\.$2/;
   
   # remove wrapper
   
       $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;
     return $symb;      return $symb;
 }  }
   
Line 4322  sub deversion { Line 4714  sub deversion {
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse)=@_;      my ($thisfn,$donotrecurse)=@_;
       my $cache_str='request.symbread.cached.'.$thisfn;
       if (defined($ENV{$cache_str})) { return $ENV{$cache_str}; }
 # no filename provided? try from environment  # no filename provided? try from environment
     unless ($thisfn) {      unless ($thisfn) {
         if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }          if ($ENV{'request.symb'}) {
       return $ENV{$cache_str}=&symbclean($ENV{'request.symb'});
    }
  $thisfn=$ENV{'request.filename'};   $thisfn=$ENV{'request.filename'};
     }      }
 # is that filename actually a symb? Verify, clean, and return  # is that filename actually a symb? Verify, clean, and return
     if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {      if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
  if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); }   if (&symbverify($thisfn,$1)) {
       return $ENV{$cache_str}=&symbclean($thisfn);
    }
     }      }
     $thisfn=declutter($thisfn);      $thisfn=declutter($thisfn);
     my %hash;      my %hash;
Line 4350  sub symbread { Line 4748  sub symbread {
            unless ($syval=~/\_\d+$/) {             unless ($syval=~/\_\d+$/) {
        unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {         unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
                   &appenv('request.ambiguous' => $thisfn);                    &appenv('request.ambiguous' => $thisfn);
                   return '';    return $ENV{$cache_str}='';
                }                     }    
                $syval.=$1;                 $syval.=$1;
    }     }
Line 4397  sub symbread { Line 4795  sub symbread {
            }             }
         }          }
         if ($syval) {          if ($syval) {
            return &symbclean($syval.'___'.$thisfn);       return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn);
         }          }
     }      }
     &appenv('request.ambiguous' => $thisfn);      &appenv('request.ambiguous' => $thisfn);
     return '';      return $ENV{$cache_str}='';
 }  }
   
 # ---------------------------------------------------------- Return random seed  # ---------------------------------------------------------- Return random seed
Line 4434  sub numval2 { Line 4832  sub numval2 {
 }  }
   
 sub latest_rnd_algorithm_id {  sub latest_rnd_algorithm_id {
     return '64bit2';      return '64bit3';
   }
   
   sub get_rand_alg {
       my ($courseid)=@_;
       if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; }
       if ($courseid) {
    return $ENV{"course.$courseid.rndseed"};
       }
       return &latest_rnd_algorithm_id();
   }
   
   sub getCODE {
       if (defined($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; }
       if (defined($Apache::lonhomework::parsing_a_problem) &&
    defined($Apache::lonhomework::history{'resource.CODE'})) {
    return $Apache::lonhomework::history{'resource.CODE'};
       }
       return undef;
 }  }
   
 sub rndseed {  sub rndseed {
Line 4447  sub rndseed { Line 4863  sub rndseed {
     if (!$courseid) { $courseid=$wcourseid; }      if (!$courseid) { $courseid=$wcourseid; }
     if (!$domain) { $domain=$wdomain; }      if (!$domain) { $domain=$wdomain; }
     if (!$username) { $username=$wusername }      if (!$username) { $username=$wusername }
     my $which=$ENV{"course.$courseid.rndseed"};      my $which=&get_rand_alg();
     my $CODE=$ENV{'form.CODE'};      if (defined(&getCODE())) {
     if (defined($CODE)) {  
  return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);   return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
       } elsif ($which eq '64bit3') {
    return &rndseed_64bit3($symb,$courseid,$domain,$username);
     } elsif ($which eq '64bit2') {      } elsif ($which eq '64bit2') {
  return &rndseed_64bit2($symb,$courseid,$domain,$username);   return &rndseed_64bit2($symb,$courseid,$domain,$username);
     } elsif ($which eq '64bit') {      } elsif ($which eq '64bit') {
Line 4518  sub rndseed_64bit2 { Line 4935  sub rndseed_64bit2 {
     }      }
 }  }
   
   sub rndseed_64bit3 {
       my ($symb,$courseid,$domain,$username)=@_;
       {
    use integer;
    # strings need to be an even # of cahracters long, it it is odd the
           # last characters gets thrown away
    my $symbchck=unpack("%32S*",$symb.' ') << 21;
    my $symbseed=numval2($symb) << 10;
    my $namechck=unpack("%32S*",$username.' ');
   
    my $nameseed=numval2($username) << 21;
    my $domainseed=unpack("%32S*",$domain.' ') << 10;
    my $courseseed=unpack("%32S*",$courseid.' ');
   
    my $num1=$symbchck+$symbseed+$namechck;
    my $num2=$nameseed+$domainseed+$courseseed;
    #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
    #&Apache::lonxml::debug("rndseed :$num:$symb");
    return "$num1:$num2";
       }
   }
   
 sub rndseed_CODE_64bit {  sub rndseed_CODE_64bit {
     my ($symb,$courseid,$domain,$username)=@_;      my ($symb,$courseid,$domain,$username)=@_;
     {      {
  use integer;   use integer;
  my $symbchck=unpack("%32S*",$symb.' ') << 16;   my $symbchck=unpack("%32S*",$symb.' ') << 16;
  my $symbseed=numval2($symb);   my $symbseed=numval2($symb);
  my $CODEchck=unpack("%32S*",$ENV{'form.CODE'}.' ') << 16;   my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
  my $CODEseed=numval($ENV{'form.CODE'});   my $CODEseed=numval(&getCODE());
  my $courseseed=unpack("%32S*",$courseid.' ');   my $courseseed=unpack("%32S*",$courseid.' ');
  my $num1=$symbseed+$CODEchck;   my $num1=$symbseed+$CODEchck;
  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");
  return "$num1,$num2";   return "$num1:$num2";
     }      }
 }  }
   
 sub setup_random_from_rndseed {  sub setup_random_from_rndseed {
     my ($rndseed)=@_;      my ($rndseed)=@_;
     if ($rndseed =~/,/) {      if ($rndseed =~/([,:])/) {
  my ($num1,$num2)=split(/,/,$rndseed);   my ($num1,$num2)=split(/[,:]/,$rndseed);
  &Math::Random::random_set_seed(abs($num1),abs($num2));   &Math::Random::random_set_seed(abs($num1),abs($num2));
     } else {      } else {
  &Math::Random::random_set_seed_from_phrase($rndseed);   &Math::Random::random_set_seed_from_phrase($rndseed);
Line 4621  sub receipt { Line 5060  sub receipt {
 # the local server.     # the local server.   
   
 sub getfile {  sub getfile {
     my ($file,$caller) = @_;      my ($file) = @_;
   
     if ($file !~ m|^/*uploaded/(\w+)/(\w+)/(.+)$|) {      if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); }
  # normal file from res space      &repcopy($file);
  &repcopy($file);      return &readfile($file);
         return &readfile($file);  }
     }  
   sub repcopy_userfile {
     my $info;      my ($file)=@_;
     my $cdom = $1;  
     my $cnum = $2;      if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); }
     my $filename = $3;      if ($file =~ m|^/home/httpd/html/lonUsers/|) { return OK; }
     my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles';  
     my ($lwpresp,$rtncode);      my ($cdom,$cnum,$filename) = 
     my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename;   ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|);
     if (-e "$localfile") {      my ($info,$rtncode);
  my @fileinfo = stat($localfile);      my $uri="/uploaded/$cdom/$cnum/$filename";
  $lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode);      if (-e "$file") {
    my @fileinfo = stat($file);
    my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
  if ($lwpresp ne 'ok') {   if ($lwpresp ne 'ok') {
     if ($rtncode eq '404') {      if ($rtncode eq '404') {
  unlink($localfile);   unlink($file);
     }      }
       #my $ua=new LWP::UserAgent;
       #my $request=new HTTP::Request('GET',&tokenwrapper($uri));
       #my $response=$ua->request($request);
       #if ($response->is_success()) {
    # return $response->content;
    #    } else {
    # return -1;
    #    }
     return -1;      return -1;
  }   }
  if ($info < $fileinfo[9]) {   if ($info < $fileinfo[9]) {
     return &readfile($localfile);      return OK;
  }   }
  $info = '';   $info = '';
  $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);   $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
  if ($lwpresp ne 'ok') {   if ($lwpresp ne 'ok') {
     return -1;      return -1;
  }   }
     } else {      } else {
  $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);   my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
  if ($lwpresp ne 'ok') {   if ($lwpresp ne 'ok') {
     return -1;      my $ua=new LWP::UserAgent;
       my $request=new HTTP::Request('GET',&tokenwrapper($uri));
       my $response=$ua->request($request);
       if ($response->is_success()) {
    $info=$response->content;
       } else {
    return -1;
       }
  }   }
  my @parts = ($cdom,$cnum);    my @parts = ($cdom,$cnum); 
  if ($filename =~ m|^(.+)/[^/]+$|) {   if ($filename =~ m|^(.+)/[^/]+$|) {
     push @parts, split(/\//,$1);      push @parts, split(/\//,$1);
     }   }
    my $path = $perlvar{'lonDocRoot'}.'/userfiles';
  foreach my $part (@parts) {   foreach my $part (@parts) {
     $path .= '/'.$part;      $path .= '/'.$part;
     if (!-e $path) {      if (!-e $path) {
Line 4669  sub getfile { Line 5126  sub getfile {
     }      }
  }   }
     }      }
     open (FILE,">$localfile");      open(FILE,">$file");
     print FILE $info;      print FILE $info;
     close(FILE);      close(FILE);
     if ($caller eq 'uploadrep') {      return OK;
  return 'ok';  }
   
   sub tokenwrapper {
       my $uri=shift;
       $uri=~s|^http\://([^/]+)||;
       $uri=~s|^/||;
       $ENV{'user.environment'}=~/\/([^\/]+)\.id/;
       my $token=$1;
       my (undef,$udom,$uname,$file)=split('/',$uri,4);
       if ($udom && $uname && $file) {
    $file=~s|(\?\.*)*$||;
           &appenv("userfile.$udom/$uname/$file" => $ENV{'request.course.id'});
           return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri.
                  (($uri=~/\?/)?'&':'?').'token='.$token.
                                  '&tokenissued='.$perlvar{'lonHostID'};
       } else {
           return '/adm/notfound.html';
     }      }
     return $info;  
 }  }
   
 sub getuploaded {  sub getuploaded {
Line 4690  sub getuploaded { Line 5162  sub getuploaded {
  return 'failed';   return 'failed';
     }            }      
     if ($reqtype eq 'HEAD') {      if ($reqtype eq 'HEAD') {
  $$info = &Date::Parse::str2time( $response->header('Last-modified') );   $$info = &HTTP::Date::str2time( $response->header('Last-modified') );
     } elsif ($reqtype eq 'GET') {      } elsif ($reqtype eq 'GET') {
  $$info = $response->content;   $$info = $response->content;
     }      }
Line 4715  sub filelocation { Line 5187  sub filelocation {
     $location = $file;      $location = $file;
     $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;      $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
   } elsif ($file=~/^\/*uploaded/) { # is an uploaded file    } elsif ($file=~/^\/*uploaded/) { # is an uploaded file
     $location=$file;        my ($udom,$uname,$filename)=
     ($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|);
         my $home=&homeserver($uname,$udom);
         my $is_me=0;
         my @ids=&current_machine_ids();
         foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
         if ($is_me) {
     $location=&Apache::loncommon::propath($udom,$uname).
         '/userfiles/'.$filename;
         } else {
     $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
         $udom.'/'.$uname.'/'.$filename;
         }
   } else {    } else {
     $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;      $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
     $file=~s:^/res/:/:;      $file=~s:^/res/:/:;
Line 4785  sub declutter { Line 5269  sub declutter {
   
 sub clutter {  sub clutter {
     my $thisfn='/'.&declutter(shift);      my $thisfn='/'.&declutter(shift);
     unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) {       unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv|public)\//) { 
        $thisfn='/res'.$thisfn;          $thisfn='/res'.$thisfn; 
     }      }
     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 4807  sub unescape { Line 5300  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 4832  sub goodbye { Line 5335  sub goodbye {
    &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 4911  BEGIN { Line 5414  BEGIN {
  $hostip{$id}=$ip;   $hostip{$id}=$ip;
  $iphost{$ip}=$id;   $iphost{$ip}=$id;
  if ($role eq 'library') { $libserv{$id}=$name; }   if ($role eq 'library') { $libserv{$id}=$name; }
        } else {  
  if ($configline) {  
    &logthis("Skipping hosts.tab line -$configline-");  
  }  
        }         }
     }      }
     close($config);      close($config);
Line 5218  X<rolesinit()> Line 5717  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"
   
Line 5606  put($namespace,$storehash,$udom,$uname) Line 6105  put($namespace,$storehash,$udom,$uname)
   
 =item *  =item *
   
   putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp
   keys used in storehash include version information (e.g., 1:$symb:message etc.) as
   used in records written by &store and retrieved by &restore.  This function 
   was created for use in editing discussion posts, without incrementing the
   version number included in the key for a particular post. The colon 
   separated list of attribute names (e.g., the value associated with the key 
   1:keys:$symb) is also generated and passed in the ampersand separated 
   items sent to lonnet::reply().  
   
   =item *
   
 cput($namespace,$storehash,$udom,$uname) : critical put  cput($namespace,$storehash,$udom,$uname) : critical put
 ($udom and $uname are optional)  ($udom and $uname are optional)
   
Removed from v.1.484  
changed lines
  Added in v.1.559

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