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

version 1.750, 2006/06/19 21:01:01 version 1.799, 2006/10/23 21:22:44
Line 52  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 lib '/home/httpd/lib/perl';
 use LONCAPA;  use LONCAPA;
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
Line 281  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;
       {
    open(my $idf,"$lonidsdir/$handle.id");
    flock($idf,LOCK_SH);
    @profile=<$idf>;
    close($idf);
       }
       my %temp_env;
       foreach my $line (@profile) {
    if ($line !~ m/=/) {
       return 0;
    }
    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)) {      if (!defined($lonidsdir)) {
  $lonidsdir = $perlvar{'lonIDsDir'};   $lonidsdir = $perlvar{'lonIDsDir'};
     }      }
Line 292  sub transfer_profile_to_env { Line 334  sub transfer_profile_to_env {
         ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );          ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
     }      }
   
     my @profile;      my $convert;
     {      {
  open(my $idf,"$lonidsdir/$handle.id");      open(my $idf,"$lonidsdir/$handle.id");
  flock($idf,LOCK_SH);   flock($idf,LOCK_SH);
  @profile=<$idf>;   if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
  close($idf);   &GDBM_READER(),0640)) {
       @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
       untie(%disk_env);
    } else {
       $convert = 1;
    }
     }      }
     my $envi;      if ($convert) {
     my %Remove;   if (!&convert_and_load_session_env($lonidsdir,$handle)) {
     for ($envi=0;$envi<=$#profile;$envi++) {      &logthis("Failed to load session, or convert session.");
  chomp($profile[$envi]);   }
  my ($envname,$envvalue)=split(/=/,$profile[$envi],2);      }
  $envname=&unescape($envname);  
  $envvalue=&unescape($envvalue);      my %remove;
  $env{$envname} = $envvalue;      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 333  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);  
     $name=&unescape($name);  
     $value=&unescape($value);  
     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 &escape($newname).'='.&escape($newenv{$newname})."\n";  
  }  
  close($fh);  
     }  
   
     close($lockfh);  
     return 'ok';      return 'ok';
 }  }
 # ----------------------------------------------------- Delete from Environment  # ----------------------------------------------------- Delete from Environment
Line 389  sub delenv { Line 400  sub delenv {
                 "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) {  
     my $unescaped_cur_key = &unescape($cur_key);  
     if ($unescaped_cur_key=~/^$delthis/) {   
                 my ($key) = split('=',$cur_key,2);  
  $key = &unescape($key);  
                 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 482  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 880  sub save_cache { Line 896  sub save_cache {
     &purge_remembered();      &purge_remembered();
     #&Apache::loncommon::validate_page();      #&Apache::loncommon::validate_page();
     undef(%env);      undef(%env);
       undef($env_loaded);
 }  }
   
 my $to_remember=-1;  my $to_remember=-1;
Line 1165  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 1173  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 1184  sub ssi { Line 1210  sub ssi {
     $form{'no_update_last_known'}=1;      $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 1610  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 1622  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 1874  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 1945  sub courseidput { Line 1984  sub courseidput {
 }  }
   
 sub courseiddump {  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter)=@_;      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 1954  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($typefilter),                                 &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 2027  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 2041  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 2837  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 2922  sub del { Line 2961  sub del {
 # -------------------------------------------------------------- dump interface  # -------------------------------------------------------------- dump interface
   
 sub dump {  sub dump {
    my ($namespace,$udomain,$uname,$regexp,$range)=@_;      my ($namespace,$udomain,$uname,$regexp,$range)=@_;
    if (!$udomain) { $udomain=$env{'user.domain'}; }      if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$env{'user.name'}; }      if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);      my $uhome=&homeserver($uname,$udomain);
    if ($regexp) {      if ($regexp) {
        $regexp=&escape($regexp);   $regexp=&escape($regexp);
    } else {      } else {
        $regexp='.';   $regexp='.';
    }      }
    my $rep=reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);      my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
    my @pairs=split(/\&/,$rep);      my @pairs=split(/\&/,$rep);
    my %returnhash=();      my %returnhash=();
    foreach (@pairs) {      foreach my $item (@pairs) {
       my ($key,$value)=split(/=/,$_,2);   my ($key,$value)=split(/=/,$item,2);
       $returnhash{unescape($key)}=&thaw_unescape($value);   $key = &unescape($key);
    }   next if ($key =~ /^error: 2 /);
    return %returnhash;   $returnhash{$key}=&thaw_unescape($value);
       }
       return %returnhash;
 }  }
   
 # --------------------------------------------------------- dumpstore interface  # --------------------------------------------------------- dumpstore interface
Line 3207  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 3252  sub allowed { Line 3514  sub allowed {
           
     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';
     }      }
   
Line 3264  sub allowed { Line 3527  sub allowed {
         return 'F';          return 'F';
     }      }
   
 # bre access to group if user has rgf priv for this group and course.  # bre access to group portfolio for rgf priv in group, or mdg or vcg in course.
     if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups')       if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups') 
          && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {           && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {
         if (exists($env{'request.course.id'})) {          if (exists($env{'request.course.id'})) {
Line 3276  sub allowed { Line 3539  sub allowed {
                 if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid                  if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid
                     .'/'.$dir[1]} =~/rgf\&([^\:]*)/) {                      .'/'.$dir[1]} =~/rgf\&([^\:]*)/) {
                     return $1;                       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;
                       }
                 }                  }
             }              }
         }          }
Line 3344  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 3378  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 3528  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 3591  sub allowed { Line 3865  sub allowed {
       }        }
    }     }
   
       if ($thisallowed eq 'A') {
    return 'A';
       }
    return 'F';     return 'F';
 }  }
   
Line 3837  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 3848  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 3954  sub auto_photoupdate { Line 4231  sub auto_photoupdate {
 }  }
   
 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 4100  sub devalidate_getgroups_cache { Line 4428  sub devalidate_getgroups_cache {
   
 sub plaintext {  sub plaintext {
     my ($short,$type,$cid) = @_;      my ($short,$type,$cid) = @_;
       if ($short =~ /^cr/) {
    return (split('/',$short))[-1];
       }
     if (!defined($cid)) {      if (!defined($cid)) {
         $cid = $env{'request.course.id'};          $cid = $env{'request.course.id'};
     }      }
Line 4569  sub is_locked { Line 4900  sub is_locked {
     }      }
 }  }
   
   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 4577  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 4666  sub get_portfile_permissions { Line 5006  sub get_portfile_permissions {
   
 sub get_access_controls {  sub get_access_controls {
     my ($current_permissions,$group,$file) = @_;      my ($current_permissions,$group,$file) = @_;
     my %access;       my %access;
       my $real_file = $file;
       $file =~ s/\.meta$//;
     if (defined($file)) {      if (defined($file)) {
         if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') {          if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') {
             foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) {              foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) {
                 $access{$file}{$control} = $$current_permissions{$file."\0".$control};                  $access{$real_file}{$control} = $$current_permissions{$file."\0".$control};
             }              }
         }          }
     } else {      } else {
Line 4693  sub get_access_controls { Line 5035  sub get_access_controls {
     return %access;      return %access;
 }  }
   
 sub parse_access_controls {  
     my ($access_item) = @_;  
     my %content;  
     my $token;  
     my $parser=HTML::TokeParser->new(\$access_item);  
     while ($token=$parser->get_token) {  
         if ($token->[0] eq 'S')  {  
             my $entry=$token->[1];  
             if ($entry eq 'scope') {  
                 my $type = $token->[2]{'type'};  
             } else {  
                 my $value=$parser->get_text('/'.$entry);  
                 $content{$entry}=$value;  
             }  
         }  
     }  
     return %content;  
 }  
   
 sub modify_access_controls {  sub modify_access_controls {
     my ($file_name,$changes,$domain,$user)=@_;      my ($file_name,$changes,$domain,$user)=@_;
     my ($outcome,$deloutcome);      my ($outcome,$deloutcome);
Line 4728  sub modify_access_controls { Line 5051  sub modify_access_controls {
             for (my $i=0; $i<$numnew; $i++) {              for (my $i=0; $i<$numnew; $i++) {
                 my $newkey = $newitems[$i];                  my $newkey = $newitems[$i];
                 my $newid = &Apache::loncommon::get_cgi_id();                  my $newid = &Apache::loncommon::get_cgi_id();
                 $newkey =~ s/^(\d+)/$newid/;                  if ($newkey =~ /^\d+:/) { 
                 $translation{$1} = $newid;                      $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} =                   $new_values{$file_name."\0".$newkey} = 
                                           $$changes{'activate'}{$newitems[$i]};                                            $$changes{'activate'}{$newitems[$i]};
                 $new_control{$newkey} = $now;                  $new_control{$newkey} = $now;
Line 4817  sub get_marked_as_readonly { Line 5145  sub get_marked_as_readonly {
         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 eq 'ARRAY')) {                  if (ref($stored_what) eq 'ARRAY') {
                     $cmp2=join('',@{$stored_what});                      $cmp2=join('',@{$stored_what});
                 }                  }
                 if ($cmp1 eq $cmp2) {                  if ($cmp1 eq $cmp2) {
Line 4869  sub unmark_as_readonly { Line 5197  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,$group) = @_;      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,$group);      my %current_permissions = &dump('file_permissions',$domain,$user,$group);
Line 4876  sub unmark_as_readonly { Line 5205  sub unmark_as_readonly {
     if ($tmp=~/^error:/) { undef(%current_permissions); }      if ($tmp=~/^error:/) { undef(%current_permissions); }
     my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group);      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;
Line 4923  sub dirlist { Line 5253  sub dirlist {
     if(defined($alternateDirectoryRoot)) {      if(defined($alternateDirectoryRoot)) {
         $dirRoot = $alternateDirectoryRoot;          $dirRoot = $alternateDirectoryRoot;
         $dirRoot =~ s/\/$//;          $dirRoot =~ s/\/$//;
     }Clay Greene      }
   
     if($udom) {      if($udom) {
         if($uname) {          if($uname) {
Line 5027  sub GetFileTimestamp { Line 5357  sub GetFileTimestamp {
   
 sub stat_file {  sub stat_file {
     my ($uri) = @_;      my ($uri) = @_;
     $uri = &clutter($uri);      $uri = &clutter_with_no_wrapper($uri);
   
     # we want just the url part without the unneeded accessor url bits  
     if ($uri =~ m-^/adm/-) {  
  $uri=~s-^/adm/wrapper/-/-;  
  $uri=~s-^/adm/coursedocs/showdoc/-/-;  
     }  
     my ($udom,$uname,$file,$dir);      my ($udom,$uname,$file,$dir);
     if ($uri =~ m-^/(uploaded|editupload)/-) {      if ($uri =~ m-^/(uploaded|editupload)/-) {
  ($udom,$uname,$file) =   ($udom,$uname,$file) =
Line 5150  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 5264  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 5502  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 5652  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 5871  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 5905  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 5954  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 6239  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 6265  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 6306  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 6327  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 6351  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 6373  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 6397  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 6422  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 6441  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 6503  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 6527  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 6793  sub clutter { Line 7166  sub clutter {
     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 6845  BEGIN { Line 7227  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 6949  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 7011  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 7208  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 7277  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 8004  Internal notes: Line 8377  Internal notes:
     
  Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.   Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.
   
 parse_access_controls():  
   
 Parses XML of an access control record  
 Args  
 1. Text string (XML) of access comtrol record  
   
 Returns:  
 1. Hash of access control settings.   
   
 modify_access_controls():  modify_access_controls():
   
 Modifies access controls for a portfolio file  Modifies access controls for a portfolio file
Removed from v.1.750  
changed lines
  Added in v.1.799

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