[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.683.2.14 and 1.749

version 1.683.2.14, 2006/01/31 22:02:03 version 1.749, 2006/06/16 22:37:35
Line 38  use vars Line 38  use vars
 qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom   qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom 
    %libserv %pr %prp $memcache %packagetab      %libserv %pr %prp $memcache %packagetab 
    %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount      %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf     %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
    %domaindescription %domain_auth_def %domain_auth_arg_def      %domaindescription %domain_auth_def %domain_auth_arg_def 
    %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary     %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary
    $tmpdir $_64bit %env);     $tmpdir $_64bit %env);
   
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
 use Apache::Constants qw(:common :http);  
 use HTML::LCParser;  use HTML::LCParser;
 use HTML::Parser;  use HTML::Parser;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
Line 53  use Storable qw(lock_store lock_nstore l Line 52  use Storable qw(lock_store lock_nstore l
 use Time::HiRes qw( gettimeofday tv_interval );  use Time::HiRes qw( gettimeofday tv_interval );
 use Cache::Memcached;  use Cache::Memcached;
 use Digest::MD5;  use Digest::MD5;
   use lib '/home/httpd/lib/perl';
   use LONCAPA;
   use LONCAPA::Configuration;
   
 my $readit;  my $readit;
 my $max_connection_retries = 10;     # Or some such value.  my $max_connection_retries = 10;     # Or some such value.
Line 86  delayed. Line 88  delayed.
   
   
 # --------------------------------------------------------------------- Logging  # --------------------------------------------------------------------- Logging
   {
       my $logid;
       sub instructor_log {
    my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;
    $logid++;
    my $id=time().'00000'.$$.'00000'.$logid;
    return &Apache::lonnet::put('nohist_'.$hash_name,
       { $id => {
    'exe_uname' => $env{'user.name'},
    'exe_udom'  => $env{'user.domain'},
    'exe_time'  => time(),
    'exe_ip'    => $ENV{'REMOTE_ADDR'},
    'delflag'   => $delflag,
    'logentry'  => $storehash,
    'uname'     => $uname,
    'udom'      => $udom,
       }
     },
       $env{'course.'.$env{'request.course.id'}.'.domain'},
       $env{'course.'.$env{'request.course.id'}.'.num'}
       );
       }
   }
   
 sub logtouch {  sub logtouch {
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
Line 124  sub logperm { Line 149  sub logperm {
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
 sub subreply {  sub subreply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     my $peerfile="$perlvar{'lonSockDir'}/$server";      my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
     #      #
     #  With loncnew process trimming, there's a timing hole between lonc server      #  With loncnew process trimming, there's a timing hole between lonc server
     #  process exit and the master server picking up the listen on the AF_UNIX      #  process exit and the master server picking up the listen on the AF_UNIX
Line 152  sub subreply { Line 177  sub subreply {
     }      }
     my $answer;      my $answer;
     if ($client) {      if ($client) {
  print $client "$cmd\n";   print $client "sethost:$server:$cmd\n";
  $answer=<$client>;   $answer=<$client>;
  if (!$answer) { $answer="con_lost"; }   if (!$answer) { $answer="con_lost"; }
  chomp($answer);   chomp($answer);
Line 260  sub critical { Line 285  sub critical {
   
 sub transfer_profile_to_env {  sub transfer_profile_to_env {
     my ($lonidsdir,$handle)=@_;      my ($lonidsdir,$handle)=@_;
       if (!defined($lonidsdir)) {
    $lonidsdir = $perlvar{'lonIDsDir'};
       }
       if (!defined($handle)) {
           ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
       }
   
     my @profile;      my @profile;
     {      {
  open(my $idf,"$lonidsdir/$handle.id");   open(my $idf,"$lonidsdir/$handle.id");
Line 272  sub transfer_profile_to_env { Line 304  sub transfer_profile_to_env {
     for ($envi=0;$envi<=$#profile;$envi++) {      for ($envi=0;$envi<=$#profile;$envi++) {
  chomp($profile[$envi]);   chomp($profile[$envi]);
  my ($envname,$envvalue)=split(/=/,$profile[$envi],2);   my ($envname,$envvalue)=split(/=/,$profile[$envi],2);
    $envname=&unescape($envname);
    $envvalue=&unescape($envvalue);
  $env{$envname} = $envvalue;   $env{$envname} = $envvalue;
         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {          if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
             if ($time < time-300) {              if ($time < time-300) {
Line 289  sub transfer_profile_to_env { Line 323  sub transfer_profile_to_env {
   
 sub appenv {  sub appenv {
     my %newenv=@_;      my %newenv=@_;
     foreach (keys %newenv) {      foreach my $key (keys(%newenv)) {
  if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {   if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) {
             &logthis("<font color=\"blue\">WARNING: ".              &logthis("<font color=\"blue\">WARNING: ".
                 "Attempt to modify environment ".$_." to ".$newenv{$_}                  "Attempt to modify environment ".$key." to ".$newenv{$key}
                 .'</font>');                  .'</font>');
     delete($newenv{$_});      delete($newenv{$key});
         } else {          } else {
             $env{$_}=$newenv{$_};              $env{$key}=$newenv{$key};
         }          }
     }      }
   
Line 324  sub appenv { Line 358  sub appenv {
         chomp($oldenv[$i]);          chomp($oldenv[$i]);
         if ($oldenv[$i] ne '') {          if ($oldenv[$i] ne '') {
     my ($name,$value)=split(/=/,$oldenv[$i],2);      my ($name,$value)=split(/=/,$oldenv[$i],2);
       $name=&unescape($name);
       $value=&unescape($value);
     unless (defined($newenv{$name})) {      unless (defined($newenv{$name})) {
  $newenv{$name}=$value;   $newenv{$name}=$value;
     }      }
Line 336  sub appenv { Line 372  sub appenv {
  }   }
  my $newname;   my $newname;
  foreach $newname (keys %newenv) {   foreach $newname (keys %newenv) {
     print $fh "$newname=$newenv{$newname}\n";      print $fh &escape($newname).'='.&escape($newenv{$newname})."\n";
  }   }
  close($fh);   close($fh);
     }      }
Line 348  sub appenv { Line 384  sub appenv {
   
 sub delenv {  sub delenv {
     my $delthis=shift;      my $delthis=shift;
     my %newenv=();  
     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {      if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
         &logthis("<font color=\"blue\">WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
                 "Attempt to delete from environment ".$delthis);                  "Attempt to delete from environment ".$delthis);
Line 380  sub delenv { Line 415  sub delenv {
     close($fh);      close($fh);
     return 'error: '.$!;      return 'error: '.$!;
  }   }
  foreach (@oldenv) {   foreach my $cur_key (@oldenv) {
     if ($_=~/^$delthis/) {       my $unescaped_cur_key = &unescape($cur_key);
                 my ($key,undef) = split('=',$_,2);      if ($unescaped_cur_key=~/^$delthis/) { 
                   my ($key) = split('=',$cur_key,2);
    $key = &unescape($key);
                 delete($env{$key});                  delete($env{$key});
             } else {              } else {
                 print $fh $_;                   print $fh $cur_key; 
             }              }
  }   }
  close($fh);   close($fh);
Line 840  sub getsection { Line 877  sub getsection {
 }  }
   
 sub save_cache {  sub save_cache {
     my ($r)=@_;  
     if (! $r->is_initial_req()) { return DECLINED; }  
     &purge_remembered();      &purge_remembered();
       #&Apache::loncommon::validate_page();
     undef(%env);      undef(%env);
     return OK;  
 }  }
   
 my $to_remember=-1;  my $to_remember=-1;
Line 947  sub userenvironment { Line 982  sub userenvironment {
 sub studentphoto {  sub studentphoto {
     my ($udom,$unam,$ext) = @_;      my ($udom,$unam,$ext) = @_;
     my $home=&Apache::lonnet::homeserver($unam,$udom);      my $home=&Apache::lonnet::homeserver($unam,$udom);
     my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext",$home);      if (defined($env{'request.course.id'})) {
     my $url="/uploaded/$udom/$unam/internal/studentphoto.".$ext;          if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {
     if ($ret ne 'ok') {              if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
  return '/adm/lonKaputt/lonlogo_broken.gif';                  return(&retrievestudentphoto($udom,$unam,$ext)); 
               } else {
                   my ($result,$perm_reqd)=
       &Apache::lonnet::auto_photo_permission($unam,$udom);
                   if ($result eq 'ok') {
                       if (!($perm_reqd eq 'yes')) {
                           return(&retrievestudentphoto($udom,$unam,$ext));
                       }
                   }
               }
           }
       } else {
           my ($result,$perm_reqd) = 
       &Apache::lonnet::auto_photo_permission($unam,$udom);
           if ($result eq 'ok') {
               if (!($perm_reqd eq 'yes')) {
                   return(&retrievestudentphoto($udom,$unam,$ext));
               }
           }
       }
       return '/adm/lonKaputt/lonlogo_broken.gif';
   }
   
   sub retrievestudentphoto {
       my ($udom,$unam,$ext,$type) = @_;
       my $home=&Apache::lonnet::homeserver($unam,$udom);
       my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home);
       if ($ret eq 'ok') {
           my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";
           if ($type eq 'thumbnail') {
               $url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext"; 
           }
           my $tokenurl=&Apache::lonnet::tokenwrapper($url);
           return $tokenurl;
       } else {
           if ($type eq 'thumbnail') {
               return '/adm/lonKaputt/genericstudent_tn.gif';
           } else { 
               return '/adm/lonKaputt/lonlogo_broken.gif';
           }
     }      }
     my $tokenurl=&Apache::lonnet::tokenwrapper($url);  
     return $tokenurl;  
 }  }
   
 # -------------------------------------------------------------------- New chat  # -------------------------------------------------------------------- New chat
   
 sub chatsend {  sub chatsend {
     my ($newentry,$anon)=@_;      my ($newentry,$anon,$group)=@_;
     my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'};      my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'};
     my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};      my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
     my $chome=$env{'course.'.$env{'request.course.id'}.'.home'};      my $chome=$env{'course.'.$env{'request.course.id'}.'.home'};
     &reply('chatsend:'.$cdom.':'.$cnum.':'.      &reply('chatsend:'.$cdom.':'.$cnum.':'.
    &escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'.     &escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'.
    &escape($newentry)),$chome);     &escape($newentry)).':'.$group,$chome);
 }  }
   
 # ------------------------------------------ Find current version of a resource  # ------------------------------------------ Find current version of a resource
Line 1108  sub ssi { Line 1180  sub ssi {
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
           
     my $request;      my $request;
       
       $form{'no_update_last_known'}=1;
   
     if (%form) {      if (%form) {
       $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);        $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);
       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));        $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
Line 1280  sub clean_filename { Line 1354  sub clean_filename {
 }  }
   
 # --------------- Take an uploaded file and put it into the userfiles directory  # --------------- Take an uploaded file and put it into the userfiles directory
 # input: name of form element, coursedoc=1 means this is for the course  # input: $formname - the contents of the file are in $env{"form.$formname"}
 # output: url of file in userspace  #                    the desired filenam is in $env{"form.$formname.filename"}
   #        $coursedoc - if true up to the current course
   #                     if false
   #        $subdir - directory in userfile to store the file into
   #        $parser, $allfiles, $codebase - unknown
   #
   # output: url of file in userspace, or error: <message> 
   #             or /adm/notfound.html if failure to upload occurse
   
   
 sub userfileupload {  sub userfileupload {
     my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase)=@_;      my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_;
     if (!defined($subdir)) { $subdir='unknown'; }      if (!defined($subdir)) { $subdir='unknown'; }
     my $fname=$env{'form.'.$formname.'.filename'};      my $fname=$env{'form.'.$formname.'.filename'};
     $fname=&clean_filename($fname);      $fname=&clean_filename($fname);
Line 1306  sub userfileupload { Line 1387  sub userfileupload {
         open(my $fh,'>'.$fullpath.'/'.$fname);          open(my $fh,'>'.$fullpath.'/'.$fname);
         print $fh $env{'form.'.$formname};          print $fh $env{'form.'.$formname};
         close($fh);          close($fh);
         return $fullpath.'/'.$fname;           return $fullpath.'/'.$fname;
       } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { #files uploaded to create course page are handled differently
           my $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.
                          '_'.$env{'user.domain'}.'/pending';
           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
     $fname="$subdir/$fname";      $fname="$subdir/$fname";
     if ($coursedoc) {      if ($coursedoc) {
Line 1323  sub userfileupload { Line 1420  sub userfileupload {
        $fname,$formname,$parser,         $fname,$formname,$parser,
        $allfiles,$codebase);         $allfiles,$codebase);
         }          }
       } elsif (defined($destuname)) {
           my $docuname=$destuname;
           my $docudom=$destudom;
    return &finishuserfileupload($docuname,$docudom,$formname,
        $fname,$parser,$allfiles,$codebase);
           
     } else {      } else {
         my $docuname=$env{'user.name'};          my $docuname=$env{'user.name'};
         my $docudom=$env{'user.domain'};          my $docudom=$env{'user.domain'};
           if (exists($env{'form.group'})) {
               $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
               $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
           }
  return &finishuserfileupload($docuname,$docudom,$formname,   return &finishuserfileupload($docuname,$docudom,$formname,
      $fname,$parser,$allfiles,$codebase);       $fname,$parser,$allfiles,$codebase);
     }      }
Line 1351  sub finishuserfileupload { Line 1458  sub finishuserfileupload {
     }      }
 # Save the file  # Save the file
     {      {
  open(FH,'>'.$filepath.'/'.$file);   if (!open(FH,'>'.$filepath.'/'.$file)) {
  print FH $env{'form.'.$formname};      &logthis('Failed to create '.$filepath.'/'.$file);
       print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
       return '/adm/notfound.html';
    }
    if (!print FH ($env{'form.'.$formname})) {
       &logthis('Failed to write to '.$filepath.'/'.$file);
       print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
       return '/adm/notfound.html';
    }
  close(FH);   close(FH);
     }      }
     if ($parser eq 'parse') {      if ($parser eq 'parse') {
Line 1551  sub flushcourselogs { Line 1666  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}).':'.&escape($courseownerbuf{$crsid});                           ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
         } else {          } else {
            $courseidbuffer{$coursehombuf{$crsid}}=             $courseidbuffer{$coursehombuf{$crsid}}=
  &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).   &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
                          ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid});                           ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
         }          }
     }      }
 #  #
Line 1658  sub courselog { Line 1773  sub courselog {
        $env{'course.'.$env{'request.course.id'}.'.internal.coursecode'};         $env{'course.'.$env{'request.course.id'}.'.internal.coursecode'};
     $courseownerbuf{$env{'request.course.id'}}=      $courseownerbuf{$env{'request.course.id'}}=
        $env{'course.'.$env{'request.course.id'}.'.internal.courseowner'};         $env{'course.'.$env{'request.course.id'}.'.internal.courseowner'};
       $coursetypebuf{$env{'request.course.id'}}=
          $env{'course.'.$env{'request.course.id'}.'.type'};
     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 1828  sub courseidput { Line 1945  sub courseidput {
 }  }
   
 sub courseiddump {  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref)=@_;      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter)=@_;
     my %returnhash=();      my %returnhash=();
     unless ($domfilter) { $domfilter=''; }      unless ($domfilter) { $domfilter=''; }
     foreach my $tryserver (keys %libserv) {      foreach my $tryserver (keys %libserv) {
Line 1837  sub courseiddump { Line 1954  sub courseiddump {
         foreach (          foreach (
                  split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.                   split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
        $sincefilter.':'.&escape($descfilter).':'.         $sincefilter.':'.&escape($descfilter).':'.
                                &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter),                                 &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter),
                                $tryserver))) {                                 $tryserver))) {
     my ($key,$value)=split(/\=/,$_);      my ($key,$value)=split(/\=/,$_);
                     if (($key) && ($value)) {                      if (($key) && ($value)) {
Line 1855  sub courseiddump { Line 1972  sub courseiddump {
 sub dcmailput {  sub dcmailput {
     my ($domain,$msgid,$message,$server)=@_;      my ($domain,$msgid,$message,$server)=@_;
     my $status = &Apache::lonnet::critical(      my $status = &Apache::lonnet::critical(
        'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='.         'dcmailput:'.$domain.':'.&escape($msgid).'='.
        &Apache::lonnet::escape($message),$server);         &escape($message),$server);
     return $status;      return $status;
 }  }
   
Line 2503  sub restore { Line 2620  sub restore {
 # ---------------------------------------------------------- Course Description  # ---------------------------------------------------------- Course Description
   
 sub coursedescription {  sub coursedescription {
     my $courseid=shift;      my ($courseid,$args)=@_;
     $courseid=~s/^\///;      $courseid=~s/^\///;
     $courseid=~s/\_/\//g;      $courseid=~s/\_/\//g;
     my ($cdomain,$cnum)=split(/\//,$courseid);      my ($cdomain,$cnum)=split(/\//,$courseid);
Line 2513  sub coursedescription { Line 2630  sub coursedescription {
     # trying and trying and trying to get the course description.      # trying and trying and trying to get the course description.
     my %envhash=();      my %envhash=();
     my %returnhash=();      my %returnhash=();
     $envhash{'course.'.$normalid.'.last_cache'}=time;      
       my $expiretime=600;
       if ($env{'request.course.id'} eq $normalid) {
    $expiretime=120;
       }
   
       my $prefix='course.'.$cdomain.'_'.$cnum.'.';
       if (!$args->{'freshen_cache'}
    && ((time-$env{$prefix.'last_cache'}) < $expiretime) ) {
    foreach my $key (keys(%env)) {
       next if ($key !~ /^\Q$prefix\E(.*)/);
       my ($setting) = $1;
       $returnhash{$setting} = $env{$key};
    }
    return %returnhash;
       }
   
       # get the data agin
       if (!$args->{'one_time'}) {
    $envhash{'course.'.$normalid.'.last_cache'}=time;
       }
     if ($chome ne 'no_host') {      if ($chome ne 'no_host') {
        %returnhash=&dump('environment',$cdomain,$cnum);         %returnhash=&dump('environment',$cdomain,$cnum);
        if (!exists($returnhash{'con_lost'})) {         if (!exists($returnhash{'con_lost'})) {
            $returnhash{'home'}= $chome;             $returnhash{'home'}= $chome;
    $returnhash{'domain'} = $cdomain;     $returnhash{'domain'} = $cdomain;
    $returnhash{'num'} = $cnum;     $returnhash{'num'} = $cnum;
              if (!defined($returnhash{'type'})) {
                  $returnhash{'type'} = 'Course';
              }
            while (my ($name,$value) = each %returnhash) {             while (my ($name,$value) = each %returnhash) {
                $envhash{'course.'.$normalid.'.'.$name}=$value;                 $envhash{'course.'.$normalid.'.'.$name}=$value;
            }             }
Line 2531  sub coursedescription { Line 2671  sub coursedescription {
            $envhash{'course.'.$normalid.'.num'}=$cnum;             $envhash{'course.'.$normalid.'.num'}=$cnum;
        }         }
     }      }
     &appenv(%envhash);      if (!$args->{'one_time'}) {
    &appenv(%envhash);
       }
     return %returnhash;      return %returnhash;
 }  }
   
Line 2574  sub rolesinit { Line 2716  sub rolesinit {
     my %allroles=();      my %allroles=();
     my %allgroups=();         my %allgroups=();   
     my $now=time;      my $now=time;
     my $userroles="user.login.time=$now\n";      my %userroles = ('user.login.time' => $now);
     my $group_privs;      my $group_privs;
   
     if ($rolesdump ne '') {      if ($rolesdump ne '') {
Line 2597  sub rolesinit { Line 2739  sub rolesinit {
     } else {      } else {
  ($trole,$tend,$tstart)=split(/_/,$role);   ($trole,$tend,$tstart)=split(/_/,$role);
     }      }
             $userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username);      my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
    $username);
       @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
             if (($tend!=0) && ($tend<$now)) { $trole=''; }              if (($tend!=0) && ($tend<$now)) { $trole=''; }
             if (($tstart!=0) && ($tstart>$now)) { $trole=''; }              if (($tstart!=0) && ($tstart>$now)) { $trole=''; }
             if (($area ne '') && ($trole ne '')) {              if (($area ne '') && ($trole ne '')) {
Line 2613  sub rolesinit { Line 2757  sub rolesinit {
             }              }
           }            }
         }          }
         my ($author,$adv) = &set_userprivs(\$userroles,\%allroles,\%allgroups);          my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups);
         $userroles.='user.adv='.$adv."\n".          $userroles{'user.adv'}    = $adv;
             'user.author='.$author."\n";   $userroles{'user.author'} = $author;
         $env{'user.adv'}=$adv;          $env{'user.adv'}=$adv;
     }      }
     return $userroles;        return \%userroles;  
 }  }
   
 sub set_arearole {  sub set_arearole {
     my ($trole,$area,$tstart,$tend,$domain,$username) = @_;      my ($trole,$area,$tstart,$tend,$domain,$username) = @_;
 # log the associated role with the area  # log the associated role with the area
     &userrolelog($trole,$username,$domain,$area,$tstart,$tend);      &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
     return 'user.role.'.$trole.'.'.$area.'='.$tstart.'.'.$tend."\n";      return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);
 }  }
   
 sub custom_roleprivs {  sub custom_roleprivs {
Line 2727  sub set_userprivs { Line 2871  sub set_userprivs {
         }          }
         my $thesestr='';          my $thesestr='';
         foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }          foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }
         $$userroles.='user.priv.'.$_.'='.$thesestr."\n";          $userroles->{'user.priv.'.$_} = $thesestr;
     }      }
     return ($author,$adv);      return ($author,$adv);
 }  }
Line 2778  sub del { Line 2922  sub del {
 # -------------------------------------------------------------- dump interface  # -------------------------------------------------------------- dump interface
   
 sub dump {  sub dump {
    my ($namespace,$udomain,$uname,$regexp)=@_;     my ($namespace,$udomain,$uname,$regexp,$range)=@_;
    if (!$udomain) { $udomain=$env{'user.domain'}; }     if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$env{'user.name'}; }     if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
Line 2787  sub dump { Line 2931  sub dump {
    } else {     } else {
        $regexp='.';         $regexp='.';
    }     }
    my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome);     my $rep=reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
    my @pairs=split(/\&/,$rep);     my @pairs=split(/\&/,$rep);
    my %returnhash=();     my %returnhash=();
    foreach (@pairs) {     foreach (@pairs) {
       my ($key,$value)=split(/=/,$_);        my ($key,$value)=split(/=/,$_,2);
       $returnhash{unescape($key)}=&thaw_unescape($value);        $returnhash{unescape($key)}=&thaw_unescape($value);
    }     }
    return %returnhash;     return %returnhash;
 }  }
   
   # --------------------------------------------------------- dumpstore interface
   
   sub dumpstore {
      my ($namespace,$udomain,$uname,$regexp,$range)=@_;
      return &dump($namespace,$udomain,$uname,$regexp,$range);
   }
   
 # -------------------------------------------------------------- keys interface  # -------------------------------------------------------------- keys interface
   
 sub getkeys {  sub getkeys {
Line 2938  sub newput { Line 3089  sub newput {
 # ---------------------------------------------------------  putstore interface  # ---------------------------------------------------------  putstore interface
   
 sub putstore {  sub putstore {
    my ($namespace,$storehash,$udomain,$uname)=@_;     my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
    if (!$udomain) { $udomain=$env{'user.domain'}; }     if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$env{'user.name'}; }     if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
    my $items='';     my $items='';
    my %allitems = ();     foreach my $key (keys(%$storehash)) {
    foreach (keys %$storehash) {         $items.= &escape($key).'='.&freeze_escape($storehash->{$key}).'&';
        if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {  
            my $key = $1.':keys:'.$2;  
            $allitems{$key} .= $3.':';  
        }  
        $items.=$_.'='.&freeze_escape($$storehash{$_}).'&';  
    }  
    foreach (keys %allitems) {  
        $allitems{$_} =~ s/\:$//;  
        $items.= $_.'='.$allitems{$_}.'&';  
    }     }
    $items=~s/\&$//;     $items=~s/\&$//;
    return &reply("put:$udomain:$uname:$namespace:$items",$uhome);     my $esc_symb=&escape($symb);
      my $esc_v=&escape($version);
      my $reply =
          &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
         $uhome);
      if ($reply eq 'unknown_cmd') {
          # gfall back to way things use to be done
          return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
       $uname);
      }
      return $reply;
   }
   
   sub old_putstore {
       my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
       if (!$udomain) { $udomain=$env{'user.domain'}; }
       if (!$uname) { $uname=$env{'user.name'}; }
       my $uhome=&homeserver($uname,$udomain);
       my %newstorehash;
       foreach (keys %$storehash) {
    my $key = $version.':'.&escape($symb).':'.$_;
    $newstorehash{$key} = $storehash->{$_};
       }
       my $items='';
       my %allitems = ();
       foreach (keys %newstorehash) {
    if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
       my $key = $1.':keys:'.$2;
       $allitems{$key} .= $3.':';
    }
    $items.=$_.'='.&freeze_escape($newstorehash{$_}).'&';
       }
       foreach (keys %allitems) {
    $allitems{$_} =~ s/\:$//;
    $items.= $_.'='.$allitems{$_}.'&';
       }
       $items=~s/\&$//;
       return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
 }  }
   
 # ------------------------------------------------------ critical put interface  # ------------------------------------------------------ critical put interface
Line 2968  sub cput { Line 3147  sub cput {
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
    my $items='';     my $items='';
    foreach (keys %$storehash) {     foreach (keys %$storehash) {
        $items.=escape($_).'='.&freeze_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 3079  sub allowed { Line 3258  sub allowed {
     }      }
   
 # Free bre access to user's own portfolio contents  # Free bre access to user's own portfolio contents
     my ($space,$domain,$name,$dir)=split('/',$uri);      my ($space,$domain,$name,@dir)=split('/',$uri);
     if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&       if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && 
  ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {   ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
         return 'F';          return 'F';
     }      }
   
   # bre access to group if user has rgf priv for this group and course.
       if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups') 
            && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {
           if (exists($env{'request.course.id'})) {
               my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
               my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
               if (($domain eq $cdom) && ($name eq $cnum)) {
                   my $courseprivid=$env{'request.course.id'};
                   $courseprivid=~s/\_/\//;
                   if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid
                       .'/'.$dir[1]} =~/rgf\&([^\:]*)/) {
                       return $1; 
                   }
               }
           }
       }
   
 # Free bre to public access  # Free bre to public access
   
     if ($priv eq 'bre') {      if ($priv eq 'bre') {
Line 3299  sub allowed { Line 3495  sub allowed {
        my ($cdom,$cnum,$csec)=split(/\//,$courseid);         my ($cdom,$cnum,$csec)=split(/\//,$courseid);
                my $prefix='course.'.$cdom.'_'.$cnum.'.';                 my $prefix='course.'.$cdom.'_'.$cnum.'.';
                if ((time-$env{$prefix.'last_cache'})>$expiretime) {                 if ((time-$env{$prefix.'last_cache'})>$expiretime) {
    &coursedescription($courseid);     &coursedescription($courseid,{'freshen_cache' => 1});
                }                 }
                if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)                 if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)
                 || ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {                  || ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
Line 3398  sub allowed { Line 3594  sub allowed {
    return 'F';     return 'F';
 }  }
   
   sub split_uri_for_cond {
       my $uri=&deversion(&declutter(shift));
       my @uriparts=split(/\//,$uri);
       my $filename=pop(@uriparts);
       my $pathname=join('/',@uriparts);
       return ($pathname,$filename);
   }
 # --------------------------------------------------- Is a resource on the map?  # --------------------------------------------------- Is a resource on the map?
   
 sub is_on_map {  sub is_on_map {
     my $uri=&deversion(&declutter(shift));      my ($pathname,$filename) = &split_uri_for_cond(shift);
     my @uriparts=split(/\//,$uri);  
     my $filename=$uriparts[$#uriparts];  
     my $pathname=$uri;  
     $pathname=~s|/\Q$filename\E$||;  
     $pathname=~s/^adm\/wrapper\///;  
     $pathname=~s/^adm\/coursedocs\/showdoc\///;  
     #Trying to find the conditional for the file      #Trying to find the conditional for the file
     my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~      my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~
        /\&\Q$filename\E\:([\d\|]+)\&/);         /\&\Q$filename\E\:([\d\|]+)\&/);
Line 3680  sub auto_create_password { Line 3877  sub auto_create_password {
     return ($authparam,$create_passwd,$authchk);      return ($authparam,$create_passwd,$authchk);
 }  }
   
   sub auto_photo_permission {
       my ($cnum,$cdom,$students) = @_;
       my $homeserver = &homeserver($cnum,$cdom);
       my ($outcome,$perm_reqd,$conditions) = 
    split(/:/,&unescape(&reply('autophotopermission:'.$cdom,$homeserver)),3);
       if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
    return (undef,undef);
       }
       return ($outcome,$perm_reqd,$conditions);
   }
   
   sub auto_checkphotos {
       my ($uname,$udom,$pid) = @_;
       my $homeserver = &homeserver($uname,$udom);
       my ($result,$resulttype);
       my $outcome = &unescape(&reply('autophotocheck:'.&escape($udom).':'.
      &escape($uname).':'.&escape($pid),
      $homeserver));
       if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
    return (undef,undef);
       }
       if ($outcome) {
           ($result,$resulttype) = split(/:/,$outcome);
       } 
       return ($result,$resulttype);
   }
   
   sub auto_photochoice {
       my ($cnum,$cdom) = @_;
       my $homeserver = &homeserver($cnum,$cdom);
       my ($update,$comment) = split(/:/,&unescape(&reply('autophotochoice:'.
          &escape($cdom),
          $homeserver)));
       if ($update =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
    return (undef,undef);
       }
       return ($update,$comment);
   }
   
   sub auto_photoupdate {
       my ($affiliatesref,$dom,$cnum,$photo) = @_;
       my $homeserver = &homeserver($cnum,$dom);
       my $host=$hostname{$homeserver};
       my $cmd = '';
       my $maxtries = 1;
       foreach (keys %{$affiliatesref}) {
           $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%';
       }
       $cmd =~ s/%%$//;
       $cmd = &escape($cmd);
       my $query = 'institutionalphotos';
       my $queryid=&reply("querysend:".$query.':'.$dom.':'.$cnum.':'.$cmd,$homeserver);
       unless ($queryid=~/^\Q$host\E\_/) {
           &logthis('institutionalphotos: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' and course: '.$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('institutionalphotos error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' course: '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
       } else {
           my @responses = split(/:/,$reply);
           my $outcome = shift(@responses); 
           foreach my $item (@responses) {
               my ($key,$value) = split(/=/,$item);
               $$photo{$key} = $value;
           }
           return $outcome;
       }
       return 'error';
   }
   
 sub auto_instcode_format {  sub auto_instcode_format {
     my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;      my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;
     my $courses = '';      my $courses = '';
Line 3731  sub modify_group_roles { Line 4004  sub modify_group_roles {
     my $role = 'gr/'.&escape($userprivs);      my $role = 'gr/'.&escape($userprivs);
     my ($uname,$udom) = split(/:/,$user);      my ($uname,$udom) = split(/:/,$user);
     my $result = &assignrole($udom,$uname,$url,$role,$end,$start);      my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
       if ($result eq 'ok') {
           &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
       }
     return $result;      return $result;
 }  }
   
Line 3764  sub get_group_membership { Line 4040  sub get_group_membership {
   
 sub get_users_groups {  sub get_users_groups {
     my ($udom,$uname,$courseid) = @_;      my ($udom,$uname,$courseid) = @_;
       my @usersgroups;
     my $cachetime=1800;      my $cachetime=1800;
     $courseid=~s/\_/\//g;      $courseid=~s/\_/\//g;
     $courseid=~s/^(\w)/\/$1/;      $courseid=~s/^(\w)/\/$1/;
   
     my $hashid="$udom:$uname:$courseid";      my $hashid="$udom:$uname:$courseid";
     my ($result,$cached)=&is_cached_new('getgroups',$hashid);      my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
     if (defined($cached)) { return $result; }      if (defined($cached)) {
           @usersgroups = split(/:/,$grouplist);
     my %roleshash = &dump('roles',$udom,$uname,$courseid);      } else {  
     my ($tmp) = keys(%roleshash);          $grouplist = '';
     if ($tmp=~/^error:/) {          my %roleshash = &dump('roles',$udom,$uname,$courseid);
         &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);          my ($tmp) = keys(%roleshash);
         return '';          if ($tmp=~/^error:/) {
     } else {              &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);
         my $grouplist;          } else {
         foreach my $key (keys %roleshash) {              my $access_end = $env{'course.'.$courseid.
             if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {                                    '.default_enrollment_end_date'};
                 unless ($roleshash{$key} =~ /_1_1$/) {   # deleted membership              my $now = time;
                     $grouplist .= $1.':';              foreach my $key (keys(%roleshash)) {
                   if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
                       my $group = $1;
                       if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
                           my $start = $2;
                           my $end = $1;
                           if ($start == -1) { next; } # deleted from group
                           if (($start!=0) && ($start>$now)) { next; }
                           if (($end!=0) && ($end<$now)) {
                               if ($access_end && $access_end < $now) {
                                   if ($access_end - $end < 86400) {
                                       push(@usersgroups,$group);
                                   }
                               }
                               next;
                           }
                           push(@usersgroups,$group);
                       }
                 }                  }
             }              }
               @usersgroups = &sort_course_groups($courseid,@usersgroups);
               $grouplist = join(':',@usersgroups);
               &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
         }          }
         $grouplist =~ s/:$//;  
         return &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);  
     }      }
       return @usersgroups;
 }  }
   
 sub devalidate_getgroups_cache {  sub devalidate_getgroups_cache {
Line 3803  sub devalidate_getgroups_cache { Line 4099  sub devalidate_getgroups_cache {
 # ------------------------------------------------------------------ Plain Text  # ------------------------------------------------------------------ Plain Text
   
 sub plaintext {  sub plaintext {
     my $short=shift;      my ($short,$type,$cid) = @_;
     return &Apache::lonlocal::mt($prp{$short});      if (!defined($cid)) {
           $cid = $env{'request.course.id'};
       }
       if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) {
           return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short.
                                             '.plaintext'});
       }
       my %rolenames = (
                         Course => 'std',
                         Group => 'alt1',
                       );
       if (defined($type) && 
            defined($rolenames{$type}) && 
            defined($prp{$short}{$rolenames{$type}})) {
           return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});
       } else {
           return &Apache::lonlocal::mt($prp{$short}{'std'});
       }
 }  }
   
 # ----------------------------------------------------------------- Assign Role  # ----------------------------------------------------------------- Assign Role
Line 3853  sub assignrole { Line 4166  sub assignrole {
            $command.='_0_'.$start;             $command.='_0_'.$start;
         }          }
     }      }
       my $origstart = $start;
       my $origend = $end;
 # actually delete  # actually delete
     if ($deleteflag) {      if ($deleteflag) {
  if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {   if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
Line 3870  sub assignrole { Line 4185  sub assignrole {
 # log new user role if status is ok  # log new user role if status is ok
     if ($answer eq 'ok') {      if ($answer eq 'ok') {
  &userrolelog($role,$uname,$udom,$url,$start,$end);   &userrolelog($role,$uname,$udom,$url,$start,$end);
   # for course roles, perform group memberships changes triggered by role change.
           unless ($role =~ /^gr/) {
               &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
                                                $origstart);
           }
     }      }
     return $answer;      return $answer;
 }  }
Line 4126  sub writecoursepref { Line 4446  sub writecoursepref {
 # ---------------------------------------------------------- Make/modify course  # ---------------------------------------------------------- Make/modify course
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner)=@_;      my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
           $course_owner,$crstype)=@_;
     $url=&declutter($url);      $url=&declutter($url);
     my $cid='';      my $cid='';
     unless (&allowed('ccc',$udom)) {      unless (&allowed('ccc',$udom)) {
Line 4163  sub createcourse { Line 4484  sub createcourse {
 # ----------------------------------------------------------------- Course made  # ----------------------------------------------------------------- Course made
 # log existence  # log existence
     &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).      &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
                  ':'.&escape($inst_code).':'.&escape($course_owner),$uhome);                   ':'.&escape($inst_code).':'.&escape($course_owner).':'.
                     &escape($crstype),$uhome);
     &flushcourselogs();      &flushcourselogs();
 # set toplevel url  # set toplevel url
     my $topurl=$url;      my $topurl=$url;
Line 4233  sub is_locked { Line 4555  sub is_locked {
       $env{'user.domain'},$env{'user.name'});        $env{'user.domain'},$env{'user.name'});
     my ($tmp)=keys(%locked);      my ($tmp)=keys(%locked);
     if ($tmp=~/^error:/) { undef(%locked); }      if ($tmp=~/^error:/) { undef(%locked); }
       
     if (ref($locked{$file_name}) eq 'ARRAY') {      if (ref($locked{$file_name}) eq 'ARRAY') {
         $is_locked = 'true';          $is_locked = 'false';
           foreach my $entry (@{$locked{$file_name}}) {
              if (ref($entry) eq 'ARRAY') { 
                  $is_locked = 'true';
                  last;
              }
          }
     } else {      } else {
         $is_locked = 'false';          $is_locked = 'false';
     }      }
Line 4324  sub files_not_in_path { Line 4652  sub files_not_in_path {
     return (@return_files);      return (@return_files);
 }  }
   
 #--------------------------------------------------------------Get Marked as Read Only  #----------------------------------------------Get portfolio file permissions
   
   sub get_portfile_permissions {
 sub get_marked_as_readonly {      my ($domain,$user) = @_;
     my ($domain,$user,$what) = @_;  
     my %current_permissions = &dump('file_permissions',$domain,$user);      my %current_permissions = &dump('file_permissions',$domain,$user);
     my ($tmp)=keys(%current_permissions);      my ($tmp)=keys(%current_permissions);
     if ($tmp=~/^error:/) { undef(%current_permissions); }      if ($tmp=~/^error:/) { undef(%current_permissions); }
       return \%current_permissions;
   }
   
   #---------------------------------------------Get portfolio file access controls
   
   sub get_access_controls {
       my ($current_permissions,$group,$file) = @_;
       my %access; 
       if (defined($file)) {
           if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') {
               foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) {
                   $access{$file}{$control} = $$current_permissions{$file."\0".$control};
               }
           }
       } else {
           foreach my $key (keys(%{$current_permissions})) {
               if ($key =~ /\0accesscontrol$/) {
                   if (defined($group)) {
                       if ($key !~ m-^\Q$group\E/-) {
                           next;
                       }
                   }
                   my ($fullpath) = split(/\0/,$key);
                   if (ref($$current_permissions{$key}) eq 'HASH') {
                       foreach my $control (keys(%{$$current_permissions{$key}})) {
                           $access{$fullpath}{$control}=$$current_permissions{$fullpath."\0".$control};
                       }
                   }
               }
           }
       }
       return %access;
   }
   
   sub parse_access_controls {
       my ($access_item) = @_;
       my %content;
       my $token;
       my $parser=HTML::TokeParser->new(\$access_item);
       while ($token=$parser->get_token) {
           if ($token->[0] eq 'S')  {
               my $entry=$token->[1];
               if ($entry eq 'scope') {
                   my $type = $token->[2]{'type'};
               } else {
                   my $value=$parser->get_text('/'.$entry);
                   $content{$entry}=$value;
               }
           }
       }
       return %content;
   }
   
   sub modify_access_controls {
       my ($file_name,$changes,$domain,$user)=@_;
       my ($outcome,$deloutcome);
       my %store_permissions;
       my %new_values;
       my %new_control;
       my %translation;
       my @deletions = ();
       my $now = time;
       if (exists($$changes{'activate'})) {
           if (ref($$changes{'activate'}) eq 'HASH') {
               my @newitems = sort(keys(%{$$changes{'activate'}}));
               my $numnew = scalar(@newitems);
               for (my $i=0; $i<$numnew; $i++) {
                   my $newkey = $newitems[$i];
                   my $newid = &Apache::loncommon::get_cgi_id();
                   $newkey =~ s/^(\d+)/$newid/;
                   $translation{$1} = $newid;
                   $new_values{$file_name."\0".$newkey} = 
                                             $$changes{'activate'}{$newitems[$i]};
                   $new_control{$newkey} = $now;
               }
           }
       }
       my %todelete;
       my %changed_items;
       foreach my $action ('delete','update') {
           if (exists($$changes{$action})) {
               if (ref($$changes{$action}) eq 'HASH') {
                   foreach my $key (keys(%{$$changes{$action}})) {
                       my ($itemnum) = ($key =~ /^([^:]+):/);
                       if ($action eq 'delete') { 
                           $todelete{$itemnum} = 1;
                       } else {
                           $changed_items{$itemnum} = $key;
                       }
                   }
               }
           }
       }
       # get lock on access controls for file.
       my $lockhash = {
                     $file_name."\0".'locked_access_records' => $env{'user.name'}.
                                                          ':'.$env{'user.domain'},
                      }; 
       my $tries = 0;
       my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
      
       while (($gotlock ne 'ok') && $tries <3) {
           $tries ++;
           sleep 1;
           $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
       }
       if ($gotlock eq 'ok') {
           my %curr_permissions = &dump('file_permissions',$domain,$user,$file_name);
           my ($tmp)=keys(%curr_permissions);
           if ($tmp=~/^error:/) { undef(%curr_permissions); }
           if (exists($curr_permissions{$file_name."\0".'accesscontrol'})) {
               my $curr_controls = $curr_permissions{$file_name."\0".'accesscontrol'};
               if (ref($curr_controls) eq 'HASH') {
                   foreach my $control_item (keys(%{$curr_controls})) {
                       my ($itemnum) = ($control_item =~ /^([^:]+):/);
                       if (defined($todelete{$itemnum})) {
                           push(@deletions,$file_name."\0".$control_item);
                       } else {
                           if (defined($changed_items{$itemnum})) {
                               $new_control{$changed_items{$itemnum}} = $now;
                               push(@deletions,$file_name."\0".$control_item);
                               $new_values{$file_name."\0".$changed_items{$itemnum}} = $$changes{'update'}{$changed_items{$itemnum}};
                           } else {
                               $new_control{$control_item} = $$curr_controls{$control_item};
                           }
                       }
                   }
               }
           }
           $deloutcome = &del('file_permissions',\@deletions,$domain,$user);
           $new_values{$file_name."\0".'accesscontrol'} = \%new_control;
           $outcome = &put('file_permissions',\%new_values,$domain,$user);
           #  remove lock
           my @del_lock = ($file_name."\0".'locked_access_records');
           my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
       } else {
           $outcome = "error: could not obtain lockfile\n";  
       }
       return ($outcome,$deloutcome,\%new_values,\%translation);
   }
   
   #------------------------------------------------------Get Marked as Read Only
   
   sub get_marked_as_readonly {
       my ($domain,$user,$what,$group) = @_;
       my $current_permissions = &get_portfile_permissions($domain,$user);
     my @readonly_files;      my @readonly_files;
     my $cmp1=$what;      my $cmp1=$what;
     if (ref($what)) { $cmp1=join('',@{$what}) };      if (ref($what)) { $cmp1=join('',@{$what}) };
     while (my ($file_name,$value) = each(%current_permissions)) {      while (my ($file_name,$value) = each(%{$current_permissions})) {
           if (defined($group)) {
               if ($file_name !~ m-^\Q$group\E/-) {
                   next;
               }
           }
         if (ref($value) eq "ARRAY"){          if (ref($value) eq "ARRAY"){
             foreach my $stored_what (@{$value}) {              foreach my $stored_what (@{$value}) {
                 my $cmp2=$stored_what;                  my $cmp2=$stored_what;
                 if (ref($stored_what)) { $cmp2=join('',@{$stored_what}) };                  if (ref($stored_what eq 'ARRAY')) {
                       $cmp2=join('',@{$stored_what});
                   }
                 if ($cmp1 eq $cmp2) {                  if ($cmp1 eq $cmp2) {
                     push(@readonly_files, $file_name);                      push(@readonly_files, $file_name);
                       last;
                 } elsif (!defined($what)) {                  } elsif (!defined($what)) {
                     push(@readonly_files, $file_name);                      push(@readonly_files, $file_name);
                       last;
                 }                  }
             }              }
         }           }
     }      }
     return @readonly_files;      return @readonly_files;
 }  }
 #-----------------------------------------------------------Get Marked as Read Only Hash  #-----------------------------------------------------------Get Marked as Read Only Hash
   
 sub get_marked_as_readonly_hash {  sub get_marked_as_readonly_hash {
     my ($domain,$user,$what) = @_;      my ($current_permissions,$group,$what) = @_;
     my %current_permissions = &dump('file_permissions',$domain,$user);  
     my ($tmp)=keys(%current_permissions);  
     if ($tmp=~/^error:/) { undef(%current_permissions); }  
   
     my %readonly_files;      my %readonly_files;
     while (my ($file_name,$value) = each(%current_permissions)) {      while (my ($file_name,$value) = each(%{$current_permissions})) {
           if (defined($group)) {
               if ($file_name !~ m-^\Q$group\E/-) {
                   next;
               }
           }
         if (ref($value) eq "ARRAY"){          if (ref($value) eq "ARRAY"){
             foreach my $stored_what (@{$value}) {              foreach my $stored_what (@{$value}) {
                 if ($stored_what eq $what) {                  if (ref($stored_what) eq 'ARRAY') {
                     $readonly_files{$file_name} = 'locked';                      if ($stored_what eq $what) {
                 } elsif (!defined($what)) {                          $readonly_files{$file_name} = 'locked';
                     $readonly_files{$file_name} = 'locked';                      } elsif (!defined($what)) {
                           $readonly_files{$file_name} = 'locked';
                       }
                 }                  }
             }              }
         }           } 
Line 4377  sub get_marked_as_readonly_hash { Line 4862  sub get_marked_as_readonly_hash {
 sub unmark_as_readonly {  sub unmark_as_readonly {
     # unmarks $file_name (if $file_name is defined), or all files locked by $what       # unmarks $file_name (if $file_name is defined), or all files locked by $what 
     # for portfolio submissions, $what contains [$symb,$crsid]       # for portfolio submissions, $what contains [$symb,$crsid] 
     my ($domain,$user,$what,$file_name) = @_;      my ($domain,$user,$what,$file_name,$group) = @_;
     my $symb_crs = $what;      my $symb_crs = $what;
     if (ref($what)) { $symb_crs=join('',@$what); }      if (ref($what)) { $symb_crs=join('',@$what); }
     my %current_permissions = &dump('file_permissions',$domain,$user);      my %current_permissions = &dump('file_permissions',$domain,$user,$group);
     my ($tmp)=keys(%current_permissions);      my ($tmp)=keys(%current_permissions);
     if ($tmp=~/^error:/) { undef(%current_permissions); }      if ($tmp=~/^error:/) { undef(%current_permissions); }
     my @readonly_files = &get_marked_as_readonly($domain,$user,$what);      my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group);
     foreach my $file (@readonly_files) {      foreach my $file (@readonly_files) {
  if (defined($file_name) && ($file_name ne $file)) { next; }   if (defined($file_name) && ($file_name ne $file)) { next; }
  my $current_locks = $current_permissions{$file};   my $current_locks = $current_permissions{$file};
Line 4392  sub unmark_as_readonly { Line 4877  sub unmark_as_readonly {
         if (ref($current_locks) eq "ARRAY"){          if (ref($current_locks) eq "ARRAY"){
             foreach my $locker (@{$current_locks}) {              foreach my $locker (@{$current_locks}) {
                 my $compare=$locker;                  my $compare=$locker;
                 if (ref($locker)) { $compare=join('',@{$locker}) };                  if (ref($locker) eq 'ARRAY') {
                 if ($compare ne $symb_crs) {                      $compare=join('',@{$locker});
                     push(@new_locks, $locker);                      if ($compare ne $symb_crs) {
                           push(@new_locks, $locker);
                       }
                 }                  }
             }              }
             if (scalar(@new_locks) > 0) {              if (scalar(@new_locks) > 0) {
Line 4532  sub GetFileTimestamp { Line 5019  sub GetFileTimestamp {
     }      }
 }  }
   
   sub stat_file {
       my ($uri) = @_;
       $uri = &clutter($uri);
   
       # we want just the url part without the unneeded accessor url bits
       if ($uri =~ m-^/adm/-) {
    $uri=~s-^/adm/wrapper/-/-;
    $uri=~s-^/adm/coursedocs/showdoc/-/-;
       }
       my ($udom,$uname,$file,$dir);
       if ($uri =~ m-^/(uploaded|editupload)/-) {
    ($udom,$uname,$file) =
       ($uri =~ m-/(?:uploaded|editupload)/?([^/]*)/?([^/]*)/?(.*)-);
    $file = 'userfiles/'.$file;
    $dir = &propath($udom,$uname);
       }
       if ($uri =~ m-^/res/-) {
    ($udom,$uname) = 
       ($uri =~ m-/(?:res)/?([^/]*)/?([^/]*)/-);
    $file = $uri;
       }
   
       if (!$udom || !$uname || !$file) {
    # unable to handle the uri
    return ();
       }
   
       my ($result) = &dirlist($file,$udom,$uname,$dir);
       my @stats = split('&', $result);
       
       if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
    shift(@stats); #filename is first
    return @stats;
       }
       return ();
   }
   
 # -------------------------------------------------------- Value of a Condition  # -------------------------------------------------------- Value of a Condition
   
   # gets the value of a specific preevaluated condition
   #    stored in the string  $env{user.state.<cid>}
   # or looks up a condition reference in the bighash and if if hasn't
   # already been evaluated recurses into docondval to get the value of
   # the condition, then memoizing it to 
   #   $env{user.state.<cid>.<condition>}
 sub directcondval {  sub directcondval {
     my $number=shift;      my $number=shift;
     if (!defined($env{'user.state.'.$env{'request.course.id'}})) {      if (!defined($env{'user.state.'.$env{'request.course.id'}})) {
  &Apache::lonuserstate::evalstate();   &Apache::lonuserstate::evalstate();
     }      }
       if (exists($env{'user.state.'.$env{'request.course.id'}.".$number"})) {
    return $env{'user.state.'.$env{'request.course.id'}.".$number"};
       } elsif ($number =~ /^_/) {
    my $sub_condition;
    if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
    &GDBM_READER(),0640)) {
       $sub_condition=$bighash{'conditions'.$number};
       untie(%bighash);
    }
    my $value = &docondval($sub_condition);
    &appenv('user.state.'.$env{'request.course.id'}.".$number" => $value);
    return $value;
       }
     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 4546  sub directcondval { Line 5089  sub directcondval {
     }      }
 }  }
   
   # get the collection of conditions for this resource
 sub condval {  sub condval {
     my $condidx=shift;      my $condidx=shift;
     my $result=0;  
     my $allpathcond='';      my $allpathcond='';
     foreach (split(/\|/,$condidx)) {      foreach my $cond (split(/\|/,$condidx)) {
        if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$_})) {   if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond})) {
    $allpathcond.=      $allpathcond.=
                '('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$_}.')|';   '('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond}.')|';
        }   }
     }      }
     $allpathcond=~s/\|$//;      $allpathcond=~s/\|$//;
     if ($env{'request.course.id'}) {      return &docondval($allpathcond);
        if ($allpathcond) {  }
           my $operand='|';  
   my @stack;  #evaluates an expression of conditions
            foreach ($allpathcond=~/(\d+|\(|\)|\&|\|)/g) {  sub docondval {
               if ($_ eq '(') {      my ($allpathcond) = @_;
                  push @stack,($operand,$result)      my $result=0;
               } elsif ($_ eq ')') {      if ($env{'request.course.id'}
                   my $before=pop @stack;   && defined($allpathcond)) {
   if (pop @stack eq '&') {   my $operand='|';
       $result=$result>$before?$before:$result;   my @stack;
                   } else {   foreach my $chunk ($allpathcond=~/(\d+|_\d+\.\d+|\(|\)|\&|\|)/g) {
                       $result=$result>$before?$result:$before;      if ($chunk eq '(') {
                   }   push @stack,($operand,$result);
               } elsif (($_ eq '&') || ($_ eq '|')) {      } elsif ($chunk eq ')') {
                   $operand=$_;   my $before=pop @stack;
               } else {   if (pop @stack eq '&') {
                   my $new=directcondval($_);      $result=$result>$before?$before:$result;
                   if ($operand eq '&') {   } else {
                      $result=$result>$new?$new:$result;      $result=$result>$before?$result:$before;
                   } else {   }
                      $result=$result>$new?$result:$new;      } elsif (($chunk eq '&') || ($chunk eq '|')) {
                   }   $operand=$chunk;
               }      } else {
           }   my $new=directcondval($chunk);
        }   if ($operand eq '&') {
       $result=$result>$new?$new:$result;
    } else {
       $result=$result>$new?$result:$new;
    }
       }
    }
     }      }
     return $result;      return $result;
 }  }
Line 4699  sub EXT_cache_set { Line 5248  sub EXT_cache_set {
   
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
 sub EXT {  sub EXT {
     my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;  
   
       my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;
     unless ($varname) { return ''; }      unless ($varname) { return ''; }
     #get real user name/domain, courseid and symb      #get real user name/domain, courseid and symb
     my $courseid;      my $courseid;
Line 4733  sub EXT { Line 5282  sub EXT {
     if ( (defined($Apache::lonhomework::parsing_a_problem)      if ( (defined($Apache::lonhomework::parsing_a_problem)
   || defined($Apache::lonhomework::parsing_a_task))    || defined($Apache::lonhomework::parsing_a_task))
  &&   &&
  ($symbparm eq &symbread()) ) {   ($symbparm eq &symbread()) ) {
  return $Apache::lonhomework::history{$qualifierrest};   # if we are in the middle of processing the resource the
    # get the value we are planning on committing
                   if (defined($Apache::lonhomework::results{$qualifierrest})) {
                       return $Apache::lonhomework::results{$qualifierrest};
                   } else {
                       return $Apache::lonhomework::history{$qualifierrest};
                   }
     } else {      } else {
  my %restored;   my %restored;
  if ($publicuser || $env{'request.state'} eq 'construct') {   if ($publicuser || $env{'request.state'} eq 'construct') {
Line 4814  sub EXT { Line 5369  sub EXT {
         return $env{'course.'.$courseid.'.'.$spacequalifierrest};          return $env{'course.'.$courseid.'.'.$spacequalifierrest};
     } elsif ($realm eq 'resource') {      } elsif ($realm eq 'resource') {
   
  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) { $symbparm=&symbread(); }
  }   }
   
    if ($space eq 'title') {
       if (!$symbparm) { $symbparm = $env{'request.filename'}; }
       return &gettitle($symbparm);
    }
   
    if ($space eq 'map') {
       my ($map) = &decode_symb($symbparm);
       return &symbread($map);
    }
   
    my ($section, $group, @groups);
  my ($courselevelm,$courselevel);   my ($courselevelm,$courselevel);
  if ($symbparm && defined($courseid) &&    if ($symbparm && defined($courseid) && 
     $courseid eq $env{'request.course.id'}) {      $courseid eq $env{'request.course.id'}) {
Line 4826  sub EXT { Line 5392  sub EXT {
   
 # ----------------------------------------------------- Cascading lookup scheme  # ----------------------------------------------------- Cascading lookup scheme
     my $symbp=$symbparm;      my $symbp=$symbparm;
     my $mapp=(&decode_symb($symbp))[0];      my $mapp=&deversion((&decode_symb($symbp))[0]);
   
     my $symbparm=$symbp.'.'.$spacequalifierrest;      my $symbparm=$symbp.'.'.$spacequalifierrest;
     my $mapparm=$mapp.'___(all).'.$spacequalifierrest;      my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
Line 4834  sub EXT { Line 5400  sub EXT {
     if (($env{'user.name'} eq $uname) &&      if (($env{'user.name'} eq $uname) &&
  ($env{'user.domain'} eq $udom)) {   ($env{'user.domain'} eq $udom)) {
  $section=$env{'request.course.sec'};   $section=$env{'request.course.sec'};
                   @groups = split(/:/,$env{'request.course.groups'});  
                   @groups=&sort_course_groups($courseid,@groups); 
     } else {      } else {
  if (! defined($usection)) {   if (! defined($usection)) {
     $section=&getsection($udom,$uname,$courseid);      $section=&getsection($udom,$uname,$courseid);
  } else {   } else {
     $section = $usection;      $section = $usection;
  }   }
                   @groups = &get_users_groups($udom,$uname,$courseid);
     }      }
   
     my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;      my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
Line 4855  sub EXT { Line 5424  sub EXT {
     my $userreply=&resdata($uname,$udom,'user',      my $userreply=&resdata($uname,$udom,'user',
        ($courselevelr,$courselevelm,         ($courselevelr,$courselevelm,
  $courselevel));   $courselevel));
   
     if (defined($userreply)) { return $userreply; }      if (defined($userreply)) { return $userreply; }
   
 # ------------------------------------------------ second, check some of course  # ------------------------------------------------ second, check some of course
               my $coursereply;
               if (@groups > 0) {
                   $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
                                          $mapparm,$spacequalifierrest);
                   if (defined($coursereply)) { return $coursereply; }
               }
   
     my $coursereply=&resdata($env{'course.'.$courseid.'.num'},      $coursereply=&resdata($env{'course.'.$courseid.'.num'},
      $env{'course.'.$courseid.'.domain'},       $env{'course.'.$courseid.'.domain'},
      'course',       'course',
      ($seclevelr,$seclevelm,$seclevel,       ($seclevelr,$seclevelm,$seclevel,
Line 4940  sub EXT { Line 5514  sub EXT {
     return '';      return '';
 }  }
   
   sub check_group_parms {
       my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
       my @groupitems = ();
       my $resultitem;
       my @levels = ($symbparm,$mapparm,$what);
       foreach my $group (@{$groups}) {
           foreach my $level (@levels) {
                my $item = $courseid.'.['.$group.'].'.$level;
                push(@groupitems,$item);
           }
       }
       my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
                               $env{'course.'.$courseid.'.domain'},
                                        'course',@groupitems);
       return $coursereply;
   }
   
   sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
       my ($courseid,@groups) = @_;
       @groups = sort(@groups);
       return @groups;
   }
   
 sub packages_tab_default {  sub packages_tab_default {
     my ($uri,$varname)=@_;      my ($uri,$varname)=@_;
     my (undef,$part,$name)=split(/\./,$varname);      my (undef,$part,$name)=split(/\./,$varname);
     my $packages=&metadata($uri,'packages');  
     foreach my $package (split(/,/,$packages)) {      my (@extension,@specifics,$do_default);
       foreach my $package (split(/,/,&metadata($uri,'packages'))) {
  my ($pack_type,$pack_part)=split(/_/,$package,2);   my ($pack_type,$pack_part)=split(/_/,$package,2);
    if ($pack_type eq 'default') {
       $do_default=1;
    } elsif ($pack_type eq 'extension') {
       push(@extension,[$package,$pack_type,$pack_part]);
    } else {
       push(@specifics,[$package,$pack_type,$pack_part]);
    }
       }
       # first look for a package that matches the requested part id
       foreach my $package (@specifics) {
    my (undef,$pack_type,$pack_part)=@{$package};
    next if ($pack_part ne $part);
    if (defined($packagetab{"$pack_type&$name&default"})) {
       return $packagetab{"$pack_type&$name&default"};
    }
       }
       # look for any possible matching non extension_ package
       foreach my $package (@specifics) {
    my (undef,$pack_type,$pack_part)=@{$package};
  if (defined($packagetab{"$pack_type&$name&default"})) {   if (defined($packagetab{"$pack_type&$name&default"})) {
     return $packagetab{"$pack_type&$name&default"};      return $packagetab{"$pack_type&$name&default"};
  }   }
Line 4954  sub packages_tab_default { Line 5571  sub packages_tab_default {
     return $packagetab{$pack_type."_".$pack_part."&$name&default"};      return $packagetab{$pack_type."_".$pack_part."&$name&default"};
  }   }
     }      }
       # look for any posible extension_ match
       foreach my $package (@extension) {
    my ($package,$pack_type)=@{$package};
    if (defined($packagetab{"$pack_type&$name&default"})) {
       return $packagetab{"$pack_type&$name&default"};
    }
    if (defined($packagetab{$package."&$name&default"})) {
       return $packagetab{$package."&$name&default"};
    }
       }
       # look for a global default setting
       if ($do_default && defined($packagetab{"default&$name&default"})) {
    return $packagetab{"default&$name&default"};
       }
     return undef;      return undef;
 }  }
   
Line 5039  sub metadata { Line 5670  sub metadata {
     } else {      } else {
  $metaentry{':packages'}=$package.$keyroot;   $metaentry{':packages'}=$package.$keyroot;
     }      }
     foreach (sort keys %packagetab) {      foreach my $pack_entry (keys(%packagetab)) {
  my $part=$keyroot;   my $part=$keyroot;
  $part=~s/^\_//;   $part=~s/^\_//;
  if ($_=~/^\Q$package\E\&/ ||    if ($pack_entry=~/^\Q$package\E\&/ || 
     $_=~/^\Q$package\E_0\&/) {      $pack_entry=~/^\Q$package\E_0\&/) {
     my ($pack,$name,$subp)=split(/\&/,$_);      my ($pack,$name,$subp)=split(/\&/,$pack_entry);
     # ignore package.tab specified default values      # ignore package.tab specified default values
                             # here &package_tab_default() will fetch those                              # here &package_tab_default() will fetch those
     if ($subp eq 'default') { next; }      if ($subp eq 'default') { next; }
     my $value=$packagetab{$_};      my $value=$packagetab{$pack_entry};
     my $unikey;      my $unikey;
     if ($pack =~ /_0$/) {      if ($pack =~ /_0$/) {
  $unikey='parameter_0_'.$name;   $unikey='parameter_0_'.$name;
Line 5096  sub metadata { Line 5727  sub metadata {
     my $dir=$filename;      my $dir=$filename;
     $dir=~s|[^/]*$||;      $dir=~s|[^/]*$||;
     $location=&filelocation($dir,$location);      $location=&filelocation($dir,$location);
     foreach (sort(split(/\,/,&metadata($uri,'keys',      my $metadata = 
        $location,$unikey,   &metadata($uri,'keys', $location,$unikey,
        $depthcount+1)))) {    $depthcount+1);
  $metaentry{':'.$_}=$metaentry{':'.$_};      foreach my $meta (split(',',$metadata)) {
  $metathesekeys{$_}=1;   $metaentry{':'.$meta}=$metaentry{':'.$meta};
    $metathesekeys{$meta}=1;
     }      }
  }   }
     } else {       } else { 
Line 5109  sub metadata { Line 5741  sub metadata {
     $unikey.='_'.$token->[2]->{'name'};       $unikey.='_'.$token->[2]->{'name'}; 
  }   }
  $metathesekeys{$unikey}=1;   $metathesekeys{$unikey}=1;
  foreach (@{$token->[3]}) {   foreach my $param (@{$token->[3]}) {
     $metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_};      $metaentry{':'.$unikey.'.'.$param} =
    $token->[2]->{$param};
  }   }
  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=$metaentry{':'.$unikey.'.default'};
Line 5131  sub metadata { Line 5764  sub metadata {
     }      }
  }   }
  my ($extension) = ($uri =~ /\.(\w+)$/);   my ($extension) = ($uri =~ /\.(\w+)$/);
  foreach my $key (sort(keys(%packagetab))) {   foreach my $key (keys(%packagetab)) {
     #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_package_def($uri,$key,'extension_'.$extension,      &metadata_create_package_def($uri,$key,'extension_'.$extension,
  \%metathesekeys);   \%metathesekeys);
  }   }
  if (!exists($metaentry{':packages'})) {   if (!exists($metaentry{':packages'})) {
     foreach my $key (sort(keys(%packagetab))) {      foreach my $key (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_package_def($uri,$key,'default',   &metadata_create_package_def($uri,$key,'default',
Line 5156  sub metadata { Line 5789  sub metadata {
  my $dir=$filename;   my $dir=$filename;
  $dir=~s|[^/]*$||;   $dir=~s|[^/]*$||;
  $location=&filelocation($dir,$location);   $location=&filelocation($dir,$location);
  foreach (sort(split(/\,/,&metadata($uri,'keys',   my $rights_metadata =
    $location,'_rights',      &metadata($uri,'keys',$location,'_rights',
    $depthcount+1)))) {        $depthcount+1);
     #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_};   foreach my $rights (split(',',$rights_metadata)) {
     $metathesekeys{$_}=1;      #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
       $metathesekeys{$rights}=1;
  }   }
     }      }
  }   }
  $metaentry{':keys'}=join(',',keys %metathesekeys);   # uniqifiy package listing
    my %seen;
    my @uniq_packages =
       grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
    $metaentry{':packages'} = join(',',@uniq_packages);
   
    $metaentry{':keys'} = join(',',keys(%metathesekeys));
  &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);   &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
  $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);   $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
  &do_cache_new('meta',$uri,\%metaentry,60*60);   &do_cache_new('meta',$uri,\%metaentry,60*60);
Line 5200  sub metadata_create_package_def { Line 5840  sub metadata_create_package_def {
 sub metadata_generate_part0 {  sub metadata_generate_part0 {
     my ($metadata,$metacache,$uri) = @_;      my ($metadata,$metacache,$uri) = @_;
     my %allnames;      my %allnames;
     foreach my $metakey (sort keys %$metadata) {      foreach my $metakey (keys(%$metadata)) {
  if ($metakey=~/^parameter\_(.*)/) {   if ($metakey=~/^parameter\_(.*)/) {
   my $part=$$metacache{':'.$metakey.'.part'};    my $part=$$metacache{':'.$metakey.'.part'};
   my $name=$$metacache{':'.$metakey.'.name'};    my $name=$$metacache{':'.$metakey.'.name'};
Line 5288  sub symblist { Line 5928  sub symblist {
     if (($env{'request.course.fn'}) && (%newhash)) {      if (($env{'request.course.fn'}) && (%newhash)) {
         if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',          if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
                       &GDBM_WRCREAT(),0640)) {                        &GDBM_WRCREAT(),0640)) {
     foreach (keys %newhash) {      foreach my $url (keys %newhash) {
                 $hash{declutter($_)}=&encode_symb($mapname,$newhash{$_}->[1],   next if ($url eq 'last_known'
   $newhash{$_}->[0]);   && $env{'form.no_update_last_known'});
    $hash{declutter($url)}=&encode_symb($mapname,
       $newhash{$url}->[1],
       $newhash{$url}->[0]);
             }              }
             if (untie(%hash)) {              if (untie(%hash)) {
  return 'ok';   return 'ok';
Line 6032  sub filelocation { Line 6675  sub filelocation {
         my @ids=&current_machine_ids();          my @ids=&current_machine_ids();
         foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }          foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
         if ($is_me) {          if ($is_me) {
      $location=&Apache::loncommon::propath($udom,$uname).       $location=&propath($udom,$uname).
        '/userfiles/'.$filename;         '/userfiles/'.$filename;
         } else {          } else {
    $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.     $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
Line 6137  sub clutter { Line 6780  sub clutter {
      && $thisfn!~/\.(sequence|page)$/) {       && $thisfn!~/\.(sequence|page)$/) {
  $thisfn='/adm/coursedocs/showdoc'.$thisfn;   $thisfn='/adm/coursedocs/showdoc'.$thisfn;
     } else {      } else {
  #&logthis("Got a blank emb style");  # &logthis("Got a blank emb style");
     }      }
  }   }
     }      }
Line 6153  sub freeze_escape { Line 6796  sub freeze_escape {
     return &escape($value);      return &escape($value);
 }  }
   
 # -------------------------------------------------------- Escape Special Chars  
   
 sub escape {  
     my $str=shift;  
     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;  
     return $str;  
 }  
   
 # ----------------------------------------------------- Un-Escape Special Chars  
   
 sub unescape {  
     my $str=shift;  
     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;  
     return $str;  
 }  
   
 sub thaw_unescape {  sub thaw_unescape {
     my ($value)=@_;      my ($value)=@_;
Line 6205  sub goodbye { Line 6833  sub goodbye {
    &logthis(sprintf("%-20s is %s",'hits',$hits));     &logthis(sprintf("%-20s is %s",'hits',$hits));
    &flushcourselogs();     &flushcourselogs();
    &logthis("Shutting down");     &logthis("Shutting down");
    return DONE;  
 }  }
   
 BEGIN {  BEGIN {
Line 6284  BEGIN { Line 6911  BEGIN {
     }      }
     close($config);      close($config);
     # FIXME: dev server don't want this, production servers _do_ want this      # FIXME: dev server don't want this, production servers _do_ want this
     &get_iphost();      #&get_iphost();
 }  }
   
 sub get_iphost {  sub get_iphost {
Line 6342  sub get_iphost { Line 6969  sub get_iphost {
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
  chomp($configline);   chomp($configline);
  if ($configline) {   if ($configline) {
     my ($short,$plain)=split(/:/,$configline);      my ($short,@plain)=split(/:/,$configline);
     if ($plain ne '') { $prp{$short}=$plain; }              %{$prp{$short}} = ();
       if (@plain > 0) {
                   $prp{$short}{'std'} = $plain[0];
                   for (my $i=1; $i<@plain; $i++) {
                       $prp{$short}{'alt'.$i} = $plain[$i];  
                   }
               }
  }   }
     }      }
     close($config);      close($config);
Line 6958  all args are optional Line 7591  all args are optional
   
 =item *  =item *
   
   dumpstore($namespace,$udom,$uname,$regexp,$range) : 
   dumps the complete (or key matching regexp) namespace into a hash
   ($udom, $uname, $regexp, $range are optional) for a namespace that is
   normally &store()ed into
   
   $range should be either an integer '100' (give me the first 100
                                              matching records)
                 or be  two integers sperated by a - with no spaces
                    '30-50' (give me the 30th through the 50th matching
                             records)
   
   
   =item *
   
   putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :
   replaces a &store() version of data with a replacement set of data
   for a particular resource in a namespace passed in the $storehash hash 
   reference
   
   =item *
   
 tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that  tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that
 works very similar to store/cstore, but all data is stored in a  works very similar to store/cstore, but all data is stored in a
 temporary location and can be reset using tmpreset, $storehash should  temporary location and can be reset using tmpreset, $storehash should
Line 6987  namesp ($udom and $uname are optional) Line 7641  namesp ($udom and $uname are optional)
   
 =item *  =item *
   
 dump($namespace,$udom,$uname,$regexp) :   dump($namespace,$udom,$uname,$regexp,$range) : 
 dumps the complete (or key matching regexp) namespace into a hash  dumps the complete (or key matching regexp) namespace into a hash
 ($udom, $uname and $regexp are optional)  ($udom, $uname, $regexp, $range are optional)
   
   $range should be either an integer '100' (give me the first 100
                                              matching records)
                 or be  two integers sperated by a - with no spaces
                    '30-50' (give me the 30th through the 50th matching
                             records)
 =item *  =item *
   
 inc($namespace,$store,$udom,$uname) : increments $store in $namespace.  inc($namespace,$store,$udom,$uname) : increments $store in $namespace.
Line 7006  put($namespace,$storehash,$udom,$uname) Line 7665  put($namespace,$storehash,$udom,$uname)
   
 =item *  =item *
   
 putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp  cput($namespace,$storehash,$udom,$uname) : critical put
 keys used in storehash include version information (e.g., 1:$symb:message etc.) as  ($udom and $uname are optional)
 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 *  =item *
   
 cput($namespace,$storehash,$udom,$uname) : critical put  newput($namespace,$storehash,$udom,$uname) :
 ($udom and $uname are optional)  
   Attempts to store the items in the $storehash, but only if they don't
   currently exist, if this succeeds you can be certain that you have 
   successfully created a new key value pair in the $namespace db.
   
   
   Args:
    $namespace: name of database to store values to
    $storehash: hashref to store to the db
    $udom: (optional) domain of user containing the db
    $uname: (optional) name of user caontaining the db
   
   Returns:
    'ok' -> succeeded in storing all keys of $storehash
    'key_exists: <key>' -> failed to anything out of $storehash, as at
                           least <key> already existed in the db (other
                           requested keys may also already exist)
    'error: <msg>' -> unable to tie the DB or other erorr occured
    'con_lost' -> unable to contact request server
    'refused' -> action was not allowed by remote machine
   
   
 =item *  =item *
   
Line 7146  getfile($file,$caller) : two cases - req Line 7819  getfile($file,$caller) : two cases - req
    - returns the entire contents of a file or -1;      - returns the entire contents of a file or -1; 
    it properly subscribes to and replicates the file if neccessary.     it properly subscribes to and replicates the file if neccessary.
   
   
   =item *
   
   stat_file($url) : $url is expected to be a /res/ or /uploaded/ style file
                     reference
   
   returns either a stat() list of data about the file or an empty list
   if the file doesn't exist or couldn't find out about it (connection
   problems or user unknown)
   
 =item *  =item *
   
 filelocation($dir,$file) : returns file system location of a file  filelocation($dir,$file) : returns file system location of a file
Line 7246  removeuploadedurl(): convience function Line 7929  removeuploadedurl(): convience function
   Args:    Args:
    url:  a full /uploaded/... url to delete     url:  a full /uploaded/... url to delete
   
   =item * 
   
   get_portfile_permissions():
     Args:
       domain: domain of user or course contain the portfolio files
       user: name of user or num of course contain the portfolio files
     Returns:
       hashref of a dump of the proper file_permissions.db
      
   
   =item * 
   
   get_access_controls():
   
   Args:
     current_permissions: the hash ref returned from get_portfile_permissions()
     group: (optional) the group you want the files associated with
     file: (optional) the file you want access info on
   
   Returns:
       a hash (keys are file names) of hashes containing
           keys are: path to file/file_name\0uniqueID:scope_end_start (see below)
           values are XML containing access control settings (see below) 
   
   Internal notes:
   
    access controls are stored in file_permissions.db as key=value pairs.
       key -> path to file/file_name\0uniqueID:scope_end_start
           where scope -> public,guest,course,group,domains or users.
                 end -> UNIX time for end of access (0 -> no end date)
                 start -> UNIX time for start of access
   
       value -> XML description of access control
              <scope type=""> (type =1 of: public,guest,course,group,domains,users">
               <start></start>
               <end></end>
   
               <password></password>  for scope type = guest
   
               <domain></domain>     for scope type = course or group
               <number></number>
               <roles id="">
                <role></role>
                <access></access>
                <section></section>
                <group></group>
               </roles>
   
               <dom></dom>         for scope type = domains
   
               <users>             for scope type = users
                <user>
                 <uname></uname>
                 <udom></udom>
                </user>
               </users>
              </scope> 
                 
    Access data is also aggregated for each file in an additional key=value pair:
    key -> path to file/file_name\0accesscontrol 
    value -> reference to hash
             hash contains key = value pairs
             where key = uniqueID:scope_end_start
                   value = UNIX time record was last updated
   
             Used to improve speed of look-ups of access controls for each file.  
    
    Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.
   
   parse_access_controls():
   
   Parses XML of an access control record
   Args
   1. Text string (XML) of access comtrol record
   
   Returns:
   1. Hash of access control settings. 
   
   modify_access_controls():
   
   Modifies access controls for a portfolio file
   Args
   1. file name
   2. reference to hash of required changes,
   3. domain
   4. username
     where domain,username are the domain of the portfolio owner 
     (either a user or a course) 
   
   Returns:
   1. result of additions or updates ('ok' or 'error', with error message). 
   2. result of deletions ('ok' or 'error', with error message).
   3. reference to hash of any new or updated access controls.
   4. reference to hash used to map incoming IDs to uniqueIDs assigned to control.
      key = integer (inbound ID)
      value = uniqueID  
   
 =back  =back
   
 =head2 HTTP Helper Routines  =head2 HTTP Helper Routines
Removed from v.1.683.2.14  
changed lines
  Added in v.1.749

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