[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.703 and 1.799

version 1.703, 2006/01/26 07:14:39 version 1.799, 2006/10/23 21:22:44
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 Math::Random;
   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 89  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 150  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 178  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 256  sub critical { Line 282  sub critical {
     return $answer;      return $answer;
 }  }
   
 # ------------------------------------------- Transfer profile into environment  # ------------------------------------------- check if return value is an error
   
 sub transfer_profile_to_env {  sub error {
       my ($result) = @_;
       if ($result =~ /^(con_lost|no_such_host|error: (\d+) (.*))/) {
    if ($2 == 2) { return undef; }
    return $1;
       }
       return undef;
   }
   
   sub convert_and_load_session_env {
     my ($lonidsdir,$handle)=@_;      my ($lonidsdir,$handle)=@_;
     my @profile;      my @profile;
     {      {
Line 267  sub transfer_profile_to_env { Line 302  sub transfer_profile_to_env {
  @profile=<$idf>;   @profile=<$idf>;
  close($idf);   close($idf);
     }      }
     my $envi;      my %temp_env;
     my %Remove;      foreach my $line (@profile) {
     for ($envi=0;$envi<=$#profile;$envi++) {   if ($line !~ m/=/) {
  chomp($profile[$envi]);      return 0;
  my ($envname,$envvalue)=split(/=/,$profile[$envi],2);   }
  $env{$envname} = $envvalue;   chomp($line);
    my ($envname,$envvalue)=split(/=/,$line,2);
    $temp_env{&unescape($envname)} = &unescape($envvalue);
       }
       unlink("$lonidsdir/$handle.id");
       if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(),
       0640)) {
    %disk_env = %temp_env;
    @env{keys(%temp_env)} = @disk_env{keys(%temp_env)};
    untie(%disk_env);
       }
       return 1;
   }
   
   # ------------------------------------------- Transfer profile into environment
   my $env_loaded;
   sub transfer_profile_to_env {
       my ($lonidsdir,$handle,$force_transfer) = @_;
       if (!$force_transfer && $env_loaded) { return; } 
   
       if (!defined($lonidsdir)) {
    $lonidsdir = $perlvar{'lonIDsDir'};
       }
       if (!defined($handle)) {
           ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
       }
   
       my $convert;
       {
       open(my $idf,"$lonidsdir/$handle.id");
    flock($idf,LOCK_SH);
    if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
    &GDBM_READER(),0640)) {
       @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
       untie(%disk_env);
    } else {
       $convert = 1;
    }
       }
       if ($convert) {
    if (!&convert_and_load_session_env($lonidsdir,$handle)) {
       &logthis("Failed to load session, or convert session.");
    }
       }
   
       my %remove;
       while ( my $envname = each(%env) ) {
         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {          if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
             if ($time < time-300) {              if ($time < time-300) {
                 $Remove{$key}++;                  $remove{$key}++;
             }              }
         }          }
     }      }
   
     $env{'user.environment'} = "$lonidsdir/$handle.id";      $env{'user.environment'} = "$lonidsdir/$handle.id";
     foreach my $expired_key (keys(%Remove)) {      $env_loaded=1;
       foreach my $expired_key (keys(%remove)) {
         &delenv($expired_key);          &delenv($expired_key);
     }      }
 }  }
Line 299  sub appenv { Line 382  sub appenv {
             $env{$key}=$newenv{$key};              $env{$key}=$newenv{$key};
         }          }
     }      }
       if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
     my $lockfh;      0640)) {
     unless (open($lockfh,"$env{'user.environment'}")) {   while (my ($key,$value) = each(%newenv)) {
  return 'error: '.$!;      $disk_env{$key} = $value;
     }  
     unless (flock($lockfh,LOCK_EX)) {  
          &logthis("<font color=\"blue\">WARNING: ".  
                   'Could not obtain exclusive lock in appenv: '.$!);  
          close($lockfh);  
          return 'error: '.$!;  
     }  
   
     my @oldenv;  
     {  
  my $fh;  
  unless (open($fh,"$env{'user.environment'}")) {  
     return 'error: '.$!;  
  }   }
  @oldenv=<$fh>;   untie(%disk_env);
  close($fh);  
     }      }
     for (my $i=0; $i<=$#oldenv; $i++) {  
         chomp($oldenv[$i]);  
         if ($oldenv[$i] ne '') {  
     my ($name,$value)=split(/=/,$oldenv[$i],2);  
     unless (defined($newenv{$name})) {  
  $newenv{$name}=$value;  
     }  
         }  
     }  
     {  
  my $fh;  
  unless (open($fh,">$env{'user.environment'}")) {  
     return 'error';  
  }  
  my $newname;  
  foreach $newname (keys %newenv) {  
     print $fh "$newname=$newenv{$newname}\n";  
  }  
  close($fh);  
     }  
   
     close($lockfh);  
     return 'ok';      return 'ok';
 }  }
 # ----------------------------------------------------- Delete from Environment  # ----------------------------------------------------- Delete from Environment
   
 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);
         return 'error';          return 'error';
     }      }
     my @oldenv;      if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
     {      0640)) {
  my $fh;   foreach my $key (keys(%disk_env)) {
  unless (open($fh,"$env{'user.environment'}")) {      if ($key=~/^$delthis/) { 
     return 'error';  
  }  
  unless (flock($fh,LOCK_SH)) {  
     &logthis("<font color=\"blue\">WARNING: ".  
      'Could not obtain shared lock in delenv: '.$!);  
     close($fh);  
     return 'error: '.$!;  
  }  
  @oldenv=<$fh>;  
  close($fh);  
     }  
     {  
  my $fh;  
  unless (open($fh,">$env{'user.environment'}")) {  
     return 'error';  
  }  
  unless (flock($fh,LOCK_EX)) {  
     &logthis("<font color=\"blue\">WARNING: ".  
      'Could not obtain exclusive lock in delenv: '.$!);  
     close($fh);  
     return 'error: '.$!;  
  }  
  foreach my $cur_key (@oldenv) {  
     if ($cur_key=~/^$delthis/) {   
                 my ($key,undef) = split('=',$cur_key,2);  
                 delete($env{$key});                  delete($env{$key});
             } else {                  delete($disk_env{$key});
                 print $fh $cur_key;   
             }              }
  }   }
  close($fh);   untie(%disk_env);
     }      }
     return 'ok';      return 'ok';
 }  }
   
   sub get_env_multiple {
       my ($name) = @_;
       my @values;
       if (defined($env{$name})) {
           # exists is it an array
           if (ref($env{$name})) {
               @values=@{ $env{$name} };
           } else {
               $values[0]=$env{$name};
           }
       }
       return(@values);
   }
   
 # ------------------------------------------ Find out current server userload  # ------------------------------------------ Find out current server userload
 # there is a copy in lond  # there is a copy in lond
 sub userload {  sub userload {
Line 445  sub overloaderror { Line 479  sub overloaderror {
   
 sub spareserver {  sub spareserver {
     my ($loadpercent,$userloadpercent,$want_server_name) = @_;      my ($loadpercent,$userloadpercent,$want_server_name) = @_;
     my $tryserver;      my $spare_server;
     my $spareserver='';  
     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }      if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
     my $lowestserver=$loadpercent > $userloadpercent?      my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent 
              $loadpercent :  $userloadpercent;                                                       :  $userloadpercent;
     foreach $tryserver (keys(%spareid)) {      
  my $loadans=&reply('load',$tryserver);      foreach my $try_server (@{ $spareid{'primary'} }) {
  my $userloadans=&reply('userload',$tryserver);   ($spare_server, $lowest_load) =
  if ($loadans !~ /\d/ && $userloadans !~ /\d/) {      &compare_server_load($try_server, $spare_server, $lowest_load);
     next; #didn't get a number from the server      }
  }  
  my $answer;      my $found_server = ($spare_server ne '' && $lowest_load < 100);
  if ($loadans =~ /\d/) {  
     if ($userloadans =~ /\d/) {      if (!$found_server) {
  #both are numbers, pick the bigger one   foreach my $try_server (@{ $spareid{'default'} }) {
  $answer=$loadans > $userloadans?      ($spare_server, $lowest_load) =
     $loadans :  $userloadans;   &compare_server_load($try_server, $spare_server, $lowest_load);
     } else {  
  $answer = $loadans;  
     }  
  } else {  
     $answer = $userloadans;  
  }  
  if (($answer =~ /\d/) && ($answer<$lowestserver)) {  
     if ($want_server_name) {  
  $spareserver=$tryserver;  
     } else {  
  $spareserver="http://$hostname{$tryserver}";  
     }  
     $lowestserver=$answer;  
  }   }
     }      }
     return $spareserver;  
       if (!$want_server_name) {
    $spare_server="http://$hostname{$spare_server}";
       }
       return $spare_server;
 }  }
   
   sub compare_server_load {
       my ($try_server, $spare_server, $lowest_load) = @_;
   
       my $loadans     = &reply('load',    $try_server);
       my $userloadans = &reply('userload',$try_server);
   
       if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
    next; #didn't get a number from the server
       }
   
       my $load;
       if ($loadans =~ /\d/) {
    if ($userloadans =~ /\d/) {
       #both are numbers, pick the bigger one
       $load = ($loadans > $userloadans) ? $loadans 
                                 : $userloadans;
    } else {
       $load = $loadans;
    }
       } else {
    $load = $userloadans;
       }
   
       if (($load =~ /\d/) && ($load < $lowest_load)) {
    $spare_server = $try_server;
    $lowest_load  = $load;
       }
       return ($spare_server,$lowest_load);
   }
 # --------------------------------------------- Try to change a user's password  # --------------------------------------------- Try to change a user's password
   
 sub changepass {  sub changepass {
     my ($uname,$udom,$currentpass,$newpass,$server)=@_;      my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
     $currentpass = &escape($currentpass);      $currentpass = &escape($currentpass);
     $newpass     = &escape($newpass);      $newpass     = &escape($newpass);
     my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass",      my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context",
        $server);         $server);
     if (! $answer) {      if (! $answer) {
  &logthis("No reply on password change request to $server ".   &logthis("No reply on password change request to $server ".
Line 840  sub getsection { Line 893  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;      undef($env_loaded);
 }  }
   
 my $to_remember=-1;  my $to_remember=-1;
Line 947  sub userenvironment { Line 999  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 1093  sub ssi_body { Line 1182  sub ssi_body {
     }      }
     my $output=($filelink=~/^http\:/?&externalssi($filelink):      my $output=($filelink=~/^http\:/?&externalssi($filelink):
                                      &ssi($filelink,%form));                                       &ssi($filelink,%form));
     $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s*(-->)?\s||gs;      $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
     $output=~s/^.*?\<body[^\>]*\>//si;      $output=~s/^.*?\<body[^\>]*\>//si;
     $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;      $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
     return $output;      return $output;
Line 1101  sub ssi_body { Line 1190  sub ssi_body {
   
 # --------------------------------------------------------- Server Side Include  # --------------------------------------------------------- Server Side Include
   
   sub absolute_url {
       my ($host_name) = @_;
       my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
       if ($host_name eq '') {
    $host_name = $ENV{'SERVER_NAME'};
       }
       return $protocol.$host_name;
   }
   
 sub ssi {  sub ssi {
   
     my ($fn,%form)=@_;      my ($fn,%form)=@_;
Line 1108  sub ssi { Line 1206  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',&absolute_url().$fn);
       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));        $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
     } else {      } else {
       $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);        $request=new HTTP::Request('GET',&absolute_url().$fn);
     }      }
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
Line 1281  sub clean_filename { Line 1381  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: $formname - the contents of the file are in $env{"form.$formname"}  # input: $formname - the contents of the file are in $env{"form.$formname"}
 #                    the desired filenam is in $env{"form.$formname"}  #                    the desired filenam is in $env{"form.$formname.filename"}
 #        $coursedoc - if true up to the current course  #        $coursedoc - if true up to the current course
 #                     if false  #                     if false
 #        $subdir - directory in userfile to store the file into  #        $subdir - directory in userfile to store the file into
Line 1292  sub clean_filename { Line 1392  sub clean_filename {
   
   
 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 1313  sub userfileupload { Line 1413  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 1330  sub userfileupload { Line 1446  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 1510  sub removeuploadedurl { Line 1636  sub removeuploadedurl {
 sub removeuserfile {  sub removeuserfile {
     my ($docuname,$docudom,$fname)=@_;      my ($docuname,$docudom,$fname)=@_;
     my $home=&homeserver($docuname,$docudom);      my $home=&homeserver($docuname,$docudom);
     return &reply("removeuserfile:$docudom/$docuname/$fname",$home);      my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
       if ($result eq 'ok') {
           if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
               my $metafile = $fname.'.meta';
               my $metaresult = &removeuserfile($docuname,$docudom,$metafile); 
           }
       }
       return $result;
 }  }
   
 sub mkdiruserfile {  sub mkdiruserfile {
Line 1522  sub mkdiruserfile { Line 1655  sub mkdiruserfile {
 sub renameuserfile {  sub renameuserfile {
     my ($docuname,$docudom,$old,$new)=@_;      my ($docuname,$docudom,$old,$new)=@_;
     my $home=&homeserver($docuname,$docudom);      my $home=&homeserver($docuname,$docudom);
     return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'.      my $result = &reply("renameuserfile:$docudom:$docuname:".
   &escape("$new"),$home);                          &escape("$old").':'.&escape("$new"),$home);
       if ($result eq 'ok') {
           if (($old !~ /\.meta$/) && (&is_portfolio_file($old))) {
               my $oldmeta = $old.'.meta';
               my $newmeta = $new.'.meta';
               my $metaresult = 
                   &renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
           }
       }
       return $result;
 }  }
   
 # ------------------------------------------------------------------------- Log  # ------------------------------------------------------------------------- Log
Line 1566  sub flushcourselogs { Line 1708  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 1673  sub courselog { Line 1815  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 1772  sub get_course_adv_roles { Line 1916  sub get_course_adv_roles {
     (!$nothide{$username.':'.$domain})) { next; }      (!$nothide{$username.':'.$domain})) { next; }
  if ($role eq 'cr') { next; }   if ($role eq 'cr') { next; }
         my $key=&plaintext($role);          my $key=&plaintext($role);
  if ($role =~ /^cr/) {  
     $key=(split('/',$role))[3];  
  }  
         if ($section) { $key.=' (Sec/Grp '.$section.')'; }          if ($section) { $key.=' (Sec/Grp '.$section.')'; }
         if ($returnhash{$key}) {          if ($returnhash{$key}) {
     $returnhash{$key}.=','.$username.':'.$domain;      $returnhash{$key}.=','.$username.':'.$domain;
Line 1843  sub courseidput { Line 1984  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,$regexp_ok)=@_;
     my %returnhash=();      my %returnhash=();
     unless ($domfilter) { $domfilter=''; }      unless ($domfilter) { $domfilter=''; }
     foreach my $tryserver (keys %libserv) {      foreach my $tryserver (keys %libserv) {
Line 1852  sub courseiddump { Line 1993  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).':'.&escape($regexp_ok),
                                $tryserver))) {                                 $tryserver))) {
     my ($key,$value)=split(/\=/,$_);      my ($key,$value)=split(/\=/,$_);
                     if (($key) && ($value)) {                      if (($key) && ($value)) {
Line 1870  sub courseiddump { Line 2011  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 1925  sub get_domain_roles { Line 2066  sub get_domain_roles {
   
 sub get_first_access {  sub get_first_access {
     my ($type,$argsymb)=@_;      my ($type,$argsymb)=@_;
     my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();      my ($symb,$courseid,$udom,$uname)=&whichuser();
     if ($argsymb) { $symb=$argsymb; }      if ($argsymb) { $symb=$argsymb; }
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'map') {      if ($type eq 'map') {
Line 1939  sub get_first_access { Line 2080  sub get_first_access {
   
 sub set_first_access {  sub set_first_access {
     my ($type)=@_;      my ($type)=@_;
     my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();      my ($symb,$courseid,$udom,$uname)=&whichuser();
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'map') {      if ($type eq 'map') {
  $res=&symbread($map);   $res=&symbread($map);
Line 2518  sub restore { Line 2659  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 2528  sub coursedescription { Line 2669  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 2546  sub coursedescription { Line 2710  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 2589  sub rolesinit { Line 2755  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 2612  sub rolesinit { Line 2778  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 2628  sub rolesinit { Line 2796  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 2708  sub set_userprivs { Line 2876  sub set_userprivs {
     if (keys(%{$allgroups}) > 0) {      if (keys(%{$allgroups}) > 0) {
         foreach my $role (keys %{$allroles}) {          foreach my $role (keys %{$allroles}) {
             my ($trole,$area,$sec,$extendedarea);              my ($trole,$area,$sec,$extendedarea);
             if ($role =~ m|^(\w+)\.(/\w+/\w+)(/?\w*)|) {              if ($role =~ m-^(\w+|cr/\w+/\w+/\w+)\.(/\w+/\w+)(/?\w*)-) {
                 $trole = $1;                  $trole = $1;
                 $area = $2;                  $area = $2;
                 $sec = $3;                  $sec = $3;
Line 2742  sub set_userprivs { Line 2910  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 2793  sub del { Line 2961  sub del {
 # -------------------------------------------------------------- dump interface  # -------------------------------------------------------------- dump interface
   
 sub dump {  sub dump {
       my ($namespace,$udomain,$uname,$regexp,$range)=@_;
       if (!$udomain) { $udomain=$env{'user.domain'}; }
       if (!$uname) { $uname=$env{'user.name'}; }
       my $uhome=&homeserver($uname,$udomain);
       if ($regexp) {
    $regexp=&escape($regexp);
       } else {
    $regexp='.';
       }
       my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
       my @pairs=split(/\&/,$rep);
       my %returnhash=();
       foreach my $item (@pairs) {
    my ($key,$value)=split(/=/,$item,2);
    $key = &unescape($key);
    next if ($key =~ /^error: 2 /);
    $returnhash{$key}=&thaw_unescape($value);
       }
       return %returnhash;
   }
   
   # --------------------------------------------------------- dumpstore interface
   
   sub dumpstore {
    my ($namespace,$udomain,$uname,$regexp,$range)=@_;     my ($namespace,$udomain,$uname,$regexp,$range)=@_;
    if (!$udomain) { $udomain=$env{'user.domain'}; }     return &dump($namespace,$udomain,$uname,$regexp,$range);
    if (!$uname) { $uname=$env{'user.name'}; }  
    my $uhome=&homeserver($uname,$udomain);  
    if ($regexp) {  
        $regexp=&escape($regexp);  
    } else {  
        $regexp='.';  
    }  
    my $rep=reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);  
    my @pairs=split(/\&/,$rep);  
    my %returnhash=();  
    foreach (@pairs) {  
       my ($key,$value)=split(/=/,$_,2);  
       $returnhash{unescape($key)}=&thaw_unescape($value);  
    }  
    return %returnhash;  
 }  }
   
 # -------------------------------------------------------------- keys interface  # -------------------------------------------------------------- keys interface
Line 2953  sub newput { Line 3130  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 2983  sub cput { Line 3188  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 3043  sub tmpdel { Line 3248  sub tmpdel {
     return &reply("tmpdel:$token",$server);      return &reply("tmpdel:$token",$server);
 }  }
   
   # -------------------------------------------------- portfolio access checking
   
   sub portfolio_access {
       my ($requrl) = @_;
       my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
       my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
       if ($result eq 'ok') {
          return 'F';
       } elsif ($result =~ /^[^:]+:guest_/) {
          return 'A';
       }
       return '';
   }
   
   sub get_portfolio_access {
       my ($udom,$unum,$file_name,$group,$access_hash) = @_;
   
       if (!ref($access_hash)) {
    my $current_perms = &get_portfile_permissions($udom,$unum);
    my %access_controls = &get_access_controls($current_perms,$group,
      $file_name);
    $access_hash = $access_controls{$file_name};
       }
   
       my ($public,$guest,@domains,@users,@courses,@groups);
       my $now = time;
       if (ref($access_hash) eq 'HASH') {
           foreach my $key (keys(%{$access_hash})) {
               my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
               if ($start > $now) {
                   next;
               }
               if ($end && $end<$now) {
                   next;
               }
               if ($scope eq 'public') {
                   $public = $key;
                   last;
               } elsif ($scope eq 'guest') {
                   $guest = $key;
               } elsif ($scope eq 'domains') {
                   push(@domains,$key);
               } elsif ($scope eq 'users') {
                   push(@users,$key);
               } elsif ($scope eq 'course') {
                   push(@courses,$key);
               } elsif ($scope eq 'group') {
                   push(@groups,$key);
               }
           }
           if ($public) {
               return 'ok';
           }
           if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
               if ($guest) {
                   return $guest;
               }
           } else {
               if (@domains > 0) {
                   foreach my $domkey (@domains) {
                       if (ref($access_hash->{$domkey}{'dom'}) eq 'ARRAY') {
                           if (grep(/^\Q$env{'user.domain'}\E$/,@{$access_hash->{$domkey}{'dom'}})) {
                               return 'ok';
                           }
                       }
                   }
               }
               if (@users > 0) {
                   foreach my $userkey (@users) {
                       if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {
                           return 'ok';
                       }
                   }
               }
               my %roleshash;
               my @courses_and_groups = @courses;
               push(@courses_and_groups,@groups); 
               if (@courses_and_groups > 0) {
                   my (%allgroups,%allroles); 
                   my ($start,$end,$role,$sec,$group);
                   foreach my $envkey (%env) {
                       if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./([^/]+)/([^/]+)/?([^/]*)$-) {
                           my $cid = $2.'_'.$3; 
                           if ($1 eq 'gr') {
                               $group = $4;
                               $allgroups{$cid}{$group} = $env{$envkey};
                           } else {
                               if ($4 eq '') {
                                   $sec = 'none';
                               } else {
                                   $sec = $4;
                               }
                               $allroles{$cid}{$1}{$sec} = $env{$envkey};
                           }
                       } elsif ($envkey =~ m-^user\.role\./cr/(\w+/\w+/\w*)./([^/]+)/([^/]+)/?([^/]*)$-) {
                           my $cid = $2.'_'.$3;
                           if ($4 eq '') {
                               $sec = 'none';
                           } else {
                               $sec = $4;
                           }
                           $allroles{$cid}{$1}{$sec} = $env{$envkey};
                       }
                   }
                   if (keys(%allroles) == 0) {
                       return;
                   }
                   foreach my $key (@courses_and_groups) {
                       my %content = %{$$access_hash{$key}};
                       my $cnum = $content{'number'};
                       my $cdom = $content{'domain'};
                       my $cid = $cdom.'_'.$cnum;
                       if (!exists($allroles{$cid})) {
                           next;
                       }    
                       foreach my $role_id (keys(%{$content{'roles'}})) {
                           my @sections = @{$content{'roles'}{$role_id}{'section'}};
                           my @groups = @{$content{'roles'}{$role_id}{'group'}};
                           my @status = @{$content{'roles'}{$role_id}{'access'}};
                           my @roles = @{$content{'roles'}{$role_id}{'role'}};
                           foreach my $role (keys(%{$allroles{$cid}})) {
                               if ((grep/^all$/,@roles) || (grep/^\Q$role\E$/,@roles)) {
                                   foreach my $sec (keys(%{$allroles{$cid}{$role}})) {
                                       if (&course_group_datechecker($allroles{$cid}{$role}{$sec},$now,\@status) eq 'ok') {
                                           if (grep/^all$/,@sections) {
                                               return 'ok';
                                           } else {
                                               if (grep/^$sec$/,@sections) {
                                                   return 'ok';
                                               }
                                           }
                                       }
                                   }
                                   if (keys(%{$allgroups{$cid}}) == 0) {
                                       if (grep/^none$/,@groups) {
                                           return 'ok';
                                       }
                                   } else {
                                       if (grep/^all$/,@groups) {
                                           return 'ok';
                                       } 
                                       foreach my $group (keys(%{$allgroups{$cid}})) {
                                           if (grep/^$group$/,@groups) {
                                               return 'ok';
                                           }
                                       }
                                   } 
                               }
                           }
                       }
                   }
               }
               if ($guest) {
                   return $guest;
               }
           }
       }
       return;
   }
   
   sub course_group_datechecker {
       my ($dates,$now,$status) = @_;
       my ($start,$end) = split(/\./,$dates);
       if (!$start && !$end) {
           return 'ok';
       }
       if (grep/^active$/,@{$status}) {
           if (((!$start) || ($start && $start <= $now)) && ((!$end) || ($end && $end >= $now))) {
               return 'ok';
           }
       }
       if (grep/^previous$/,@{$status}) {
           if ($end > $now ) {
               return 'ok';
           }
       }
       if (grep/^future$/,@{$status}) {
           if ($start > $now) {
               return 'ok';
           }
       }
       return; 
   }
   
   sub parse_portfolio_url {
       my ($url) = @_;
   
       my ($type,$udom,$unum,$group,$file_name);
       
       if ($url =~  m-^/*uploaded/([^/]+)/([^/]+)/portfolio(/.+)$-) {
    $type = 1;
           $udom = $1;
           $unum = $2;
           $file_name = $3;
       } elsif ($url =~ m-^/*uploaded/([^/]+)/([^/]+)/groups/([^/]+)/portfolio/(.+)$-) {
    $type = 2;
           $udom = $1;
           $unum = $2;
           $group = $3;
           $file_name = $3.'/'.$4;
       }
       if (wantarray) {
    return ($type,$udom,$unum,$file_name,$group);
       }
       return $type;
   }
   
   sub is_portfolio_url {
       my ($url) = @_;
       return scalar(&parse_portfolio_url($url));
   }
   
   sub is_portfolio_file {
       my ($file) = @_;
       if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {
           return 1;
       }
       return;
   }
   
   
 # ---------------------------------------------- Custom access rule evaluation  # ---------------------------------------------- Custom access rule evaluation
   
 sub customaccess {  sub customaccess {
Line 3081  sub customaccess { Line 3507  sub customaccess {
   
 sub allowed {  sub allowed {
     my ($priv,$uri,$symb)=@_;      my ($priv,$uri,$symb)=@_;
       my $ver_orguri=$uri;
     $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 !~ m{/(?:smppg|bulletinboard)$})) 
  || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {   || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) 
    && ($priv eq 'bre')) {
  return 'F';   return 'F';
     }      }
   
 # 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 portfolio for rgf priv in group, or mdg or vcg in 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; 
                   } else {
                       if ($env{'request.course.sec'}) {
                           $courseprivid.='/'.$env{'request.course.sec'};
                       }
                       if ($env{'user.priv.'.$env{'request.role'}.'./'.
                           $courseprivid} =~/(mdg|vcg)\&([^\:]*)/) {
                           return $2;
                       }
                   }
               }
           }
       }
   
 # Free bre to public access  # Free bre to public access
   
     if ($priv eq 'bre') {      if ($priv eq 'bre') {
Line 3162  sub allowed { Line 3615  sub allowed {
        $thisallowed.=$1;         $thisallowed.=$1;
     }      }
   
 # Group: uri itself is a group  
     my $groupuri=$uri;  
     $groupuri=~s/^([^\/])/\/$1/;  
     if ($env{'user.priv.'.$env{'request.role'}.'.'.$groupuri}  
        =~/\Q$priv\E\&([^\:]*)/) {  
        $thisallowed.=$1;  
     }  
   
 # URI is an uploaded document for this course, default permissions don't matter  # URI is an uploaded document for this course, default permissions don't matter
 # not allowing 'edit' access (editupload) to uploaded course docs  # not allowing 'edit' access (editupload) to uploaded course docs
     if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {      if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
Line 3181  sub allowed { Line 3626  sub allowed {
                 $thisallowed.=$1;                  $thisallowed.=$1;
             }              }
         } else {          } else {
             my $refuri=$env{'httpref.'.$orguri};              my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
             if ($refuri) {              if ($refuri) {
                 if ($refuri =~ m|^/adm/|) {                  if ($refuri =~ m|^/adm/|) {
                     $thisallowed='F';                      $thisallowed='F';
Line 3196  sub allowed { Line 3641  sub allowed {
         }          }
     }      }
   
       if ($priv eq 'bre'
    && $thisallowed ne 'F' 
    && $thisallowed ne '2'
    && &is_portfolio_url($uri)) {
    $thisallowed = &portfolio_access($uri);
       }
       
 # 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 3313  sub allowed { Line 3765  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 3346  sub allowed { Line 3798  sub allowed {
 #  #
   
     unless ($env{'request.course.id'}) {      unless ($env{'request.course.id'}) {
        return '1';   if ($thisallowed eq 'A') {
       return 'A';
    } else {
       return '1';
    }
     }      }
   
 #  #
Line 3409  sub allowed { Line 3865  sub allowed {
       }        }
    }     }
   
       if ($thisallowed eq 'A') {
    return 'A';
       }
    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 3654  sub auto_run { Line 4114  sub auto_run {
     my $response = &reply('autorun:'.$cdom,$homeserver);      my $response = &reply('autorun:'.$cdom,$homeserver);
     return $response;      return $response;
 }  }
                                                                                      
 sub auto_get_sections {  sub auto_get_sections {
     my ($cnum,$cdom,$inst_coursecode) = @_;      my ($cnum,$cdom,$inst_coursecode) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
Line 3665  sub auto_get_sections { Line 4125  sub auto_get_sections {
     }      }
     return @secs;      return @secs;
 }  }
                                                                                      
 sub auto_new_course {  sub auto_new_course {
     my ($cnum,$cdom,$inst_course_id,$owner) = @_;      my ($cnum,$cdom,$inst_course_id,$owner) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
     my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));      my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
     return $response;      return $response;
 }  }
                                                                                      
 sub auto_validate_courseID {  sub auto_validate_courseID {
     my ($cnum,$cdom,$inst_course_id) = @_;      my ($cnum,$cdom,$inst_course_id) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
     my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));      my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));
     return $response;      return $response;
 }  }
                                                                                      
 sub auto_create_password {  sub auto_create_password {
     my ($cnum,$cdom,$authparam) = @_;      my ($cnum,$cdom,$authparam) = @_;
     my $homeserver = &homeserver($cnum,$cdom);       my $homeserver = &homeserver($cnum,$cdom); 
Line 3694  sub auto_create_password { Line 4154  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 = '';
     my $homeserver;      my @homeservers;
     if ($caller eq 'global') {      if ($caller eq 'global') {
         foreach my $tryserver (keys %libserv) {          foreach my $tryserver (keys(%libserv)) {
             if ($hostdom{$tryserver} eq $codedom) {              if ($hostdom{$tryserver} eq $codedom) {
                 $homeserver = $tryserver;                  if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
                 last;                      push(@homeservers,$tryserver);
                   }
             }              }
         }          }
         if (($env{'user.name'}) && ($env{'user.domain'} eq $codedom)) {  
             $homeserver = &homeserver($env{'user.name'},$codedom);  
         }  
     } else {      } else {
         $homeserver = &homeserver($caller,$codedom);          push(@homeservers,&homeserver($caller,$codedom));
     }      }
     foreach (keys %{$instcodes}) {      foreach my $code (keys(%{$instcodes})) {
         $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';          $courses .= &escape($code).'='.&escape($$instcodes{$code}).'&';
     }      }
     chop($courses);      chop($courses);
     my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver);      my $ok_response = 0;
     unless ($response =~ /(con_lost|error|no_such_host|refused)/) {      my $response;
         my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response;      while (@homeservers > 0 && $ok_response == 0) {
         %{$codes} = &str2hash($codes_str);          my $server = shift(@homeservers); 
         @{$codetitles} = &str2array($codetitles_str);          $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
         %{$cat_titles} = &str2hash($cat_titles_str);          if ($response !~ /(con_lost|error|no_such_host|refused)/) {
         %{$cat_order} = &str2hash($cat_order_str);              my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = 
    split/:/,$response;
               %{$codes} = (%{$codes},&str2hash($codes_str));
               push(@{$codetitles},&str2array($codetitles_str));
               %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
               %{$cat_order} = (%{$cat_order},&str2hash($cat_order_str));
               $ok_response = 1;
           }
       }
       if ($ok_response) {
         return 'ok';          return 'ok';
       } else {
           return $response;
     }      }
   }
   
   sub auto_instcode_defaults {
       my ($domain,$returnhash,$code_order) = @_;
       my @homeservers;
       foreach my $tryserver (keys(%libserv)) {
           if ($hostdom{$tryserver} eq $domain) {
               if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
                   push(@homeservers,$tryserver);
               }
           }
       }
       my $ok_response = 0;
       my $response;
       while (@homeservers > 0 && $ok_response == 0) {
           my $server = shift(@homeservers);
           $response=&reply('autoinstcodedefaults:'.$domain,$server);
           if ($response !~ /(con_lost|error|no_such_host|refused)/) {
               foreach my $pair (split(/\&/,$response)) {
                   my ($name,$value)=split(/\=/,$pair);
                   if ($name eq 'code_order') {
                       @{$code_order} = split(/\&/,&unescape($value));
                   } else {
                       $returnhash->{&unescape($name)}=&unescape($value);
                   }
               }
           }
           $ok_response = 1;
       }
       if ($ok_response) {
           return 'ok';
       } else {
           return $response;
       }
   } 
   
   sub auto_validate_class_sec {
       my ($cdom,$cnum,$owner,$inst_class) = @_;
       my $homeserver = &homeserver($cnum,$cdom);
       my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
                           &escape($owner).':'.$cdom,$homeserver);
     return $response;      return $response;
 }  }
   
Line 3748  sub modify_group_roles { Line 4335  sub modify_group_roles {
     if ($result eq 'ok') {      if ($result eq 'ok') {
         &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);          &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
     }      }
   
     return $result;      return $result;
 }  }
   
Line 3782  sub get_group_membership { Line 4368  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 3821  sub devalidate_getgroups_cache { Line 4427  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 ($short =~ /^cr/) {
    return (split('/',$short))[-1];
       }
       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 3871  sub assignrole { Line 4497  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 3888  sub assignrole { Line 4516  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 4144  sub writecoursepref { Line 4777  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 4181  sub createcourse { Line 4815  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 4251  sub is_locked { Line 4886  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';
     }      }
 }  }
   
   sub declutter_portfile {
       my ($file) = @_;
       &logthis("got $file");
       $file =~ s-^(/portfolio/|portfolio/)-/-;
       &logthis("ret $file");
       return $file;
   }
   
 # ------------------------------------------------------------- Mark as Read Only  # ------------------------------------------------------------- Mark as Read Only
   
 sub mark_as_readonly {  sub mark_as_readonly {
Line 4267  sub mark_as_readonly { Line 4916  sub mark_as_readonly {
     my ($tmp)=keys(%current_permissions);      my ($tmp)=keys(%current_permissions);
     if ($tmp=~/^error:/) { undef(%current_permissions); }      if ($tmp=~/^error:/) { undef(%current_permissions); }
     foreach my $file (@{$files}) {      foreach my $file (@{$files}) {
    $file = &declutter_portfile($file);
         push(@{$current_permissions{$file}},$what);          push(@{$current_permissions{$file}},$what);
     }      }
     &put('file_permissions',\%current_permissions,$domain,$user);      &put('file_permissions',\%current_permissions,$domain,$user);
Line 4342  sub files_not_in_path { Line 4992  sub files_not_in_path {
     return (@return_files);      return (@return_files);
 }  }
   
 #--------------------------------------------------------------Get Marked as Read Only  #----------------------------------------------Get portfolio file permissions
   
   
 sub get_marked_as_readonly {  sub get_portfile_permissions {
     my ($domain,$user,$what) = @_;      my ($domain,$user) = @_;
     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;
       my $real_file = $file;
       $file =~ s/\.meta$//;
       if (defined($file)) {
           if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') {
               foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) {
                   $access{$real_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 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();
                   if ($newkey =~ /^\d+:/) { 
                       $newkey =~ s/^(\d+)/$newid/;
                       $translation{$1} = $newid;
                   } elsif ($newkey =~ /^\d+_\d+_\d+:/) {
                       $newkey =~ s/^(\d+_\d+_\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';                      foreach my $lock_descriptor(@{$stored_what}) {
                 } elsif (!defined($what)) {                          if ($lock_descriptor eq 'graded') {
                     $readonly_files{$file_name} = 'locked';                              $readonly_files{$file_name} = 'graded';
                 }                          } elsif ($lock_descriptor eq 'handback') {
                               $readonly_files{$file_name} = 'handback';
                           } else {
                               if (!exists($readonly_files{$file_name})) {
                                   $readonly_files{$file_name} = 'locked';
                               }
                           }
                       }
                   } 
             }              }
         }           } 
     }      }
Line 4395  sub get_marked_as_readonly_hash { Line 5196  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) = @_;
       $file_name = &declutter_portfile($file_name);
     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; }   my $clean_file = &declutter_portfile($file);
    if (defined($file_name) && ($file_name ne $clean_file)) { next; }
  my $current_locks = $current_permissions{$file};   my $current_locks = $current_permissions{$file};
         my @new_locks;          my @new_locks;
         my @del_keys;          my @del_keys;
         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 4550  sub GetFileTimestamp { Line 5355  sub GetFileTimestamp {
     }      }
 }  }
   
   sub stat_file {
       my ($uri) = @_;
       $uri = &clutter_with_no_wrapper($uri);
   
       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 4564  sub directcondval { Line 5420  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 4613  sub devalidatecourseresdata { Line 5475  sub devalidatecourseresdata {
     &devalidate_cache_new('courseres',$hashid);      &devalidate_cache_new('courseres',$hashid);
 }  }
   
   
 # --------------------------------------------------- Course Resourcedata Query  # --------------------------------------------------- Course Resourcedata Query
   
 sub get_courseresdata {  sub get_courseresdata {
Line 4717  sub EXT_cache_set { Line 5580  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 4727  sub EXT { Line 5590  sub EXT {
  $symbparm=&get_symb_from_alias($symbparm);   $symbparm=&get_symb_from_alias($symbparm);
     }      }
     if (!($uname && $udom)) {      if (!($uname && $udom)) {
       (my $cursymb,$courseid,$udom,$uname,$publicuser)=        (my $cursymb,$courseid,$udom,$uname,$publicuser)= &whichuser($symbparm);
   &Apache::lonxml::whichuser($symbparm);  
       if (!$symbparm) { $symbparm=$cursymb; }        if (!$symbparm) { $symbparm=$cursymb; }
     } else {      } else {
  $courseid=$env{'request.course.id'};   $courseid=$env{'request.course.id'};
Line 4751  sub EXT { Line 5613  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 4855  sub EXT { Line 5723  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 4863  sub EXT { Line 5731  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=&sort_course_groups($env{'request.course.groups'},$courseid);                   @groups = split(/:/,$env{'request.course.groups'});  
                 if (@groups > 0) {                  @groups=&sort_course_groups($courseid,@groups); 
                     @groups = sort(@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;
  }   }
                 my $grouplist = &get_users_groups($udom,$uname,$courseid);                  @groups = &get_users_groups($udom,$uname,$courseid);
                 if ($grouplist) {  
                     @groups=&sort_course_groups($grouplist,$courseid);  
                 }  
     }      }
   
     my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;      my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
Line 4964  sub EXT { Line 5827  sub EXT {
  if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) {   if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) {
     return $env{'environment.'.$spacequalifierrest};      return $env{'environment.'.$spacequalifierrest};
  } else {   } else {
       if ($uname eq 'anonymous' && $udom eq '') {
    return '';
       }
     my %returnhash=&userenvironment($udom,$uname,      my %returnhash=&userenvironment($udom,$uname,
     $spacequalifierrest);      $spacequalifierrest);
     return $returnhash{$spacequalifierrest};      return $returnhash{$spacequalifierrest};
Line 5000  sub check_group_parms { Line 5866  sub check_group_parms {
 }  }
   
 sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().  sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
     my ($grouplist,$courseid) = @_;      my ($courseid,@groups) = @_;
     my @groups = split/:/,$grouplist;      @groups = sort(@groups);
     if (@groups > 1) {  
         @groups = sort(@groups);  
     }  
     return @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 5022  sub packages_tab_default { Line 5905  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 5083  sub metadata { Line 5980  sub metadata {
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring;   my $metastring;
  if ($uri !~ m -^(uploaded|editupload)/-) {   if ($uri !~ m -^(editupload)/-) {
     my $file=&filelocation('',&clutter($filename));      my $file=&filelocation('',&clutter($filename));
     #push(@{$metaentry{$uri.'.file'}},$file);      #push(@{$metaentry{$uri.'.file'}},$file);
     $metastring=&getfile($file);      $metastring=&getfile($file);
Line 5107  sub metadata { Line 6004  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 5164  sub metadata { Line 6061  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 5177  sub metadata { Line 6075  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 5199  sub metadata { Line 6098  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 5224  sub metadata { Line 6123  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 5268  sub metadata_create_package_def { Line 6174  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 5293  sub metadata_generate_part0 { Line 6199  sub metadata_generate_part0 {
     }      }
 }  }
   
   # ------------------------------------------------------ Devalidate title cache
   
   sub devalidate_title_cache {
       my ($url)=@_;
       if (!$env{'request.course.id'}) { return; }
       my $symb=&symbread($url);
       if (!$symb) { return; }
       my $key=$env{'request.course.id'}."\0".$symb;
       &devalidate_cache_new('title',$key);
   }
   
 # ------------------------------------------------- Get the title of a resource  # ------------------------------------------------- Get the title of a resource
   
 sub gettitle {  sub gettitle {
Line 5327  sub gettitle { Line 6244  sub gettitle {
 sub get_slot {  sub get_slot {
     my ($which,$cnum,$cdom)=@_;      my ($which,$cnum,$cdom)=@_;
     if (!$cnum || !$cdom) {      if (!$cnum || !$cdom) {
  (undef,my $courseid)=&Apache::lonxml::whichuser();   (undef,my $courseid)=&whichuser();
  $cdom=$env{'course.'.$courseid.'.domain'};   $cdom=$env{'course.'.$courseid.'.domain'};
  $cnum=$env{'course.'.$courseid.'.num'};   $cnum=$env{'course.'.$courseid.'.num'};
     }      }
Line 5356  sub symblist { Line 6273  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 5373  sub symblist { Line 6293  sub symblist {
 sub symbverify {  sub symbverify {
     my ($symb,$thisurl)=@_;      my ($symb,$thisurl)=@_;
     my $thisfn=$thisurl;      my $thisfn=$thisurl;
 # wrapper not part of symbs  
     $thisfn=~s/^\/adm\/wrapper//;  
     $thisfn=~s/^\/adm\/coursedocs\/showdoc\///;  
     $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 5658  sub latest_rnd_algorithm_id { Line 6575  sub latest_rnd_algorithm_id {
   
 sub get_rand_alg {  sub get_rand_alg {
     my ($courseid)=@_;      my ($courseid)=@_;
     if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; }      if (!$courseid) { $courseid=(&whichuser())[1]; }
     if ($courseid) {      if ($courseid) {
  return $env{"course.$courseid.rndseed"};   return $env{"course.$courseid.rndseed"};
     }      }
Line 5684  sub getCODE { Line 6601  sub getCODE {
 sub rndseed {  sub rndseed {
     my ($symb,$courseid,$domain,$username)=@_;      my ($symb,$courseid,$domain,$username)=@_;
   
     my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser();      my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
     if (!$symb) {      if (!$symb) {
  unless ($symb=$wsymb) { return time; }   unless ($symb=$wsymb) { return time; }
     }      }
Line 5725  sub rndseed_32bit { Line 6642  sub rndseed_32bit {
  my $domainseed=unpack("%32C*",$domain) << 7;   my $domainseed=unpack("%32C*",$domain) << 7;
  my $courseseed=unpack("%32C*",$courseid);   my $courseseed=unpack("%32C*",$courseid);
  my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;   my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num:$symb");   #&logthis("rndseed :$num:$symb");
  if ($_64bit) { $num=(($num<<32)>>32); }   if ($_64bit) { $num=(($num<<32)>>32); }
  return $num;   return $num;
     }      }
Line 5746  sub rndseed_64bit { Line 6663  sub rndseed_64bit {
   
  my $num1=$symbchck+$symbseed+$namechck;   my $num1=$symbchck+$symbseed+$namechck;
  my $num2=$nameseed+$domainseed+$courseseed;   my $num2=$nameseed+$domainseed+$courseseed;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num:$symb");   #&logthis("rndseed :$num:$symb");
  if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }   if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
  if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }   if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
  return "$num1,$num2";   return "$num1,$num2";
Line 5770  sub rndseed_64bit2 { Line 6687  sub rndseed_64bit2 {
   
  my $num1=$symbchck+$symbseed+$namechck;   my $num1=$symbchck+$symbseed+$namechck;
  my $num2=$nameseed+$domainseed+$courseseed;   my $num2=$nameseed+$domainseed+$courseseed;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num:$symb");   #&logthis("rndseed :$num:$symb");
  return "$num1,$num2";   return "$num1,$num2";
     }      }
 }  }
Line 5792  sub rndseed_64bit3 { Line 6709  sub rndseed_64bit3 {
   
  my $num1=$symbchck+$symbseed+$namechck;   my $num1=$symbchck+$symbseed+$namechck;
  my $num2=$nameseed+$domainseed+$courseseed;   my $num2=$nameseed+$domainseed+$courseseed;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit");   #&logthis("rndseed :$num1:$num2:$_64bit");
  if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }   if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
   
  return "$num1:$num2";   return "$num1:$num2";
Line 5816  sub rndseed_64bit4 { Line 6733  sub rndseed_64bit4 {
   
  my $num1=$symbchck+$symbseed+$namechck;   my $num1=$symbchck+$symbseed+$namechck;
  my $num2=$nameseed+$domainseed+$courseseed;   my $num2=$nameseed+$domainseed+$courseseed;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit");   #&logthis("rndseed :$num1:$num2:$_64bit");
  if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }   if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
   
  return "$num1:$num2";   return "$num1:$num2";
Line 5841  sub rndseed_CODE_64bit { Line 6758  sub rndseed_CODE_64bit {
  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");   #&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");   #&logthis("rndseed :$num1:$num2:$symb");
  if ($_64bit) { $num1=(($num1<<32)>>32); }   if ($_64bit) { $num1=(($num1<<32)>>32); }
  if ($_64bit) { $num2=(($num2<<32)>>32); }   if ($_64bit) { $num2=(($num2<<32)>>32); }
  return "$num1:$num2";   return "$num1:$num2";
Line 5860  sub rndseed_CODE_64bit4 { Line 6777  sub rndseed_CODE_64bit4 {
  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");   #&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");   #&logthis("rndseed :$num1:$num2:$symb");
  if ($_64bit) { $num1=(($num1<<32)>>32); }   if ($_64bit) { $num1=(($num1<<32)>>32); }
  if ($_64bit) { $num2=(($num2<<32)>>32); }   if ($_64bit) { $num2=(($num2<<32)>>32); }
  return "$num1:$num2";   return "$num1:$num2";
Line 5922  sub ireceipt { Line 6839  sub ireceipt {
     my $return =&recprefix($fucourseid).'-';      my $return =&recprefix($fucourseid).'-';
     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||      if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
  $env{'request.state'} eq 'construct') {   $env{'request.state'} eq 'construct') {
  &Apache::lonxml::debug("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname).   #&logthis("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname)." and ".($cpart%$cudom));
        " and ".($cpart%$cudom));  
                 
  $return.= ($cunique%$cuname+   $return.= ($cunique%$cuname+
    $cunique%$cudom+     $cunique%$cudom+
Line 5946  sub ireceipt { Line 6862  sub ireceipt {
   
 sub receipt {  sub receipt {
     my ($part)=@_;      my ($part)=@_;
     my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();      my ($symb,$courseid,$domain,$name) = &whichuser();
     return &ireceipt($name,$domain,$courseid,$symb,$part);      return &ireceipt($name,$domain,$courseid,$symb,$part);
 }  }
   
   sub whichuser {
       my ($passedsymb)=@_;
       my ($symb,$courseid,$domain,$name,$publicuser);
       if (defined($env{'form.grade_symb'})) {
    my ($tmp_courseid)=&get_env_multiple('form.grade_courseid');
    my $allowed=&allowed('vgr',$tmp_courseid);
    if (!$allowed &&
       exists($env{'request.course.sec'}) &&
       $env{'request.course.sec'} !~ /^\s*$/) {
       $allowed=&allowed('vgr',$tmp_courseid.
         '/'.$env{'request.course.sec'});
    }
    if ($allowed) {
       ($symb)=&get_env_multiple('form.grade_symb');
       $courseid=$tmp_courseid;
       ($domain)=&get_env_multiple('form.grade_domain');
       ($name)=&get_env_multiple('form.grade_username');
       return ($symb,$courseid,$domain,$name,$publicuser);
    }
       }
       if (!$passedsymb) {
    $symb=&symbread();
       } else {
    $symb=$passedsymb;
       }
       $courseid=$env{'request.course.id'};
       $domain=$env{'user.domain'};
       $name=$env{'user.name'};
       if ($name eq 'public' && $domain eq 'public') {
    if (!defined($env{'form.username'})) {
       $env{'form.username'}.=time.rand(10000000);
    }
    $name.=$env{'form.username'};
       }
       return ($symb,$courseid,$domain,$name,$publicuser);
   
   }
   
 # ------------------------------------------------------------ Serves up a file  # ------------------------------------------------------------ Serves up a file
 # returns either the contents of the file or   # returns either the contents of the file or 
 # -1 if the file doesn't exist  # -1 if the file doesn't exist
Line 6100  sub filelocation { Line 7054  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 6205  sub clutter { Line 7159  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");
     }      }
  }   }
     }      }
     return $thisfn;      return $thisfn;
 }  }
   
   sub clutter_with_no_wrapper {
       my $uri = &clutter(shift);
       if ($uri =~ m-^/adm/-) {
    $uri =~ s-^/adm/wrapper/-/-;
    $uri =~ s-^/adm/coursedocs/showdoc/-/-;
       }
       return $uri;
   }
   
 sub freeze_escape {  sub freeze_escape {
     my ($value)=@_;      my ($value)=@_;
     if (ref($value)) {      if (ref($value)) {
Line 6221  sub freeze_escape { Line 7184  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 6273  sub goodbye { Line 7221  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 {
 # ----------------------------------- Read loncapa.conf and loncapa_apache.conf  # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
     unless ($readit) {      unless ($readit) {
 {  {
     # FIXME: Use LONCAPA::Configuration::read_conf here and omit next block      my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
     open(my $config,"</etc/httpd/conf/loncapa.conf");      %perlvar = (%perlvar,%{$configvars});
   
     while (my $configline=<$config>) {  
         if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) {  
    my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);  
            chomp($varvalue);  
            $perlvar{$varname}=$varvalue;  
         }  
     }  
     close($config);  
 }  
 {  
     open(my $config,"</etc/httpd/conf/loncapa_apache.conf");  
   
     while (my $configline=<$config>) {  
         if ($configline =~ /^[^\#]*PerlSetVar/) {  
    my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);  
            chomp($varvalue);  
            $perlvar{$varname}=$varvalue;  
         }  
     }  
     close($config);  
 }  }
   
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
Line 6384  sub get_iphost { Line 7310  sub get_iphost {
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
        chomp($configline);         chomp($configline);
        if ($configline) {         if ($configline) {
           $spareid{$configline}=1;     my ($host,$type) = split(':',$configline,2);
      if (!defined($type) || $type eq '') { $type = 'default' };
      push(@{ $spareid{$type} }, $host);
        }         }
     }      }
     close($config);      close($config);
Line 6410  sub get_iphost { Line 7338  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 6440  sub get_iphost { Line 7374  sub get_iphost {
   
 }  }
   
 $memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']});  $memcache=new Cache::Memcached({'servers'           => ['127.0.0.1:11211'],
    'compress_threshold'=> 20_000,
            });
   
 $processmarker='_'.time.'_'.$perlvar{'lonHostID'};  $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
 $dumpcount=0;  $dumpcount=0;
Line 6637  B<delenv($regexp)>: removes all items fr Line 7573  B<delenv($regexp)>: removes all items fr
 environment file that matches the regular expression in $regexp. The  environment file that matches the regular expression in $regexp. The
 values are also delted from the current processes %env.  values are also delted from the current processes %env.
   
   =item * get_env_multiple($name) 
   
   gets $name from the %env hash, it seemlessly handles the cases where multiple
   values may be defined and end up as an array ref.
   
   returns an array of values
   
 =back  =back
   
 =head2 User Information  =head2 User Information
Line 6706  actions Line 7649  actions
  '': forbidden   '': forbidden
  1: user needs to choose course   1: user needs to choose course
  2: browse allowed   2: browse allowed
    A: passphrase authentication needed
   
 =item *  =item *
   
Line 7026  all args are optional Line 7970  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 7079  put($namespace,$storehash,$udom,$uname) Line 8044  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 7219  getfile($file,$caller) : two cases - req Line 8198  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 7319  removeuploadedurl(): convience function Line 8308  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.
   
   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.703  
changed lines
  Added in v.1.799

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