[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.1172.2.14 and 1.1174

version 1.1172.2.14, 2012/12/21 17:01:04 version 1.1174, 2012/05/28 12:28:14
Line 75  use LWP::UserAgent(); Line 75  use LWP::UserAgent();
 use HTTP::Date;  use HTTP::Date;
 use Image::Magick;  use Image::Magick;
   
   use Encode;
   
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir  use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
             $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease              $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
             %managerstab);              %managerstab);
Line 97  use File::MMagic; Line 99  use File::MMagic;
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
 use LONCAPA::lonmetadata;  use LONCAPA::lonmetadata;
   use LONCAPA::Lond;
   
 use File::Copy;  use File::Copy;
   
Line 108  require Exporter; Line 111  require Exporter;
 our @ISA = qw (Exporter);  our @ISA = qw (Exporter);
 our @EXPORT = qw(%env);  our @EXPORT = qw(%env);
   
 # ------------------------------------ Logging (parameters, docs, slots, roles)  
   # --------------------------------------------------------------------- Logging
 {  {
     my $logid;      my $logid;
     sub write_log {      sub instructor_log {
  my ($context,$hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;   my ($hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
         if ($context eq 'course') {          if (($cnum eq '') || ($cdom eq '')) {
             if (($cnum eq '') || ($cdom eq '')) {              $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
                 $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};              $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
                 $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};  
             }  
         }          }
  $logid ++;   $logid++;
         my $now = time();          my $now = time();
  my $id=$now.'00000'.$$.'00000'.$logid;   my $id=$now.'00000'.$$.'00000'.$logid;
         my $logentry = {   return &Apache::lonnet::put('nohist_'.$hash_name,
                          $id => {      { $id => {
                                   'exe_uname' => $env{'user.name'},   'exe_uname' => $env{'user.name'},
                                   'exe_udom'  => $env{'user.domain'},   'exe_udom'  => $env{'user.domain'},
                                   'exe_time'  => $now,   'exe_time'  => $now,
                                   'exe_ip'    => $ENV{'REMOTE_ADDR'},   'exe_ip'    => $ENV{'REMOTE_ADDR'},
                                   'delflag'   => $delflag,   'delflag'   => $delflag,
                                   'logentry'  => $storehash,   'logentry'  => $storehash,
                                   'uname'     => $uname,   'uname'     => $uname,
                                   'udom'      => $udom,   'udom'      => $udom,
                                 }      }
                        };    },$cdom,$cnum);
         return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);  
     }      }
 }  }
   
Line 1235  sub get_lonbalancer_config { Line 1236  sub get_lonbalancer_config {
   
 sub check_loadbalancing {  sub check_loadbalancing {
     my ($uname,$udom) = @_;      my ($uname,$udom) = @_;
     my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,      my ($is_balancer,$dom_in_use,$homeintdom,$rule_in_effect,
         $rule_in_effect,$offloadto,$otherserver);          $offloadto,$otherserver);
     my $lonhost = $perlvar{'lonHostID'};      my $lonhost = $perlvar{'lonHostID'};
     my @hosts = &current_machine_ids();  
     my $uprimary_id = &Apache::lonnet::domain($udom,'primary');      my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
     my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);      my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);
     my $intdom = &Apache::lonnet::internet_dom($lonhost);      my $intdom = &Apache::lonnet::internet_dom($lonhost);
Line 1261  sub check_loadbalancing { Line 1261  sub check_loadbalancing {
         }          }
     }      }
     if (ref($result) eq 'HASH') {      if (ref($result) eq 'HASH') {
         ($is_balancer,$currtargets,$currrules) =          my $currbalancer = $result->{'lonhost'};
             &check_balancer_result($result,@hosts);          my $currtargets = $result->{'targets'};
           my $currrules = $result->{'rules'};
           if ($currbalancer ne '') {
               my @hosts = &current_machine_ids();
               if (grep(/^\Q$currbalancer\E$/,@hosts)) {
                   $is_balancer = 1;
               }
           }
         if ($is_balancer) {          if ($is_balancer) {
             if (ref($currrules) eq 'HASH') {              if (ref($currrules) eq 'HASH') {
                 if ($homeintdom) {                  if ($homeintdom) {
Line 1320  sub check_loadbalancing { Line 1327  sub check_loadbalancing {
             }              }
         }          }
         if (ref($result) eq 'HASH') {          if (ref($result) eq 'HASH') {
             ($is_balancer,$currtargets,$currrules) =              my $currbalancer = $result->{'lonhost'};
                 &check_balancer_result($result,@hosts);              my $currtargets = $result->{'targets'};
             if ($is_balancer) {              my $currrules = $result->{'rules'};
   
               if ($currbalancer eq $lonhost) {
                   $is_balancer = 1;
                 if (ref($currrules) eq 'HASH') {                  if (ref($currrules) eq 'HASH') {
                     if ($currrules->{'_LC_internetdom'} ne '') {                      if ($currrules->{'_LC_internetdom'} ne '') {
                         $rule_in_effect = $currrules->{'_LC_internetdom'};                          $rule_in_effect = $currrules->{'_LC_internetdom'};
Line 1343  sub check_loadbalancing { Line 1353  sub check_loadbalancing {
             $offloadto = &this_host_spares($dom_in_use);              $offloadto = &this_host_spares($dom_in_use);
         }          }
     }      }
     if ($is_balancer) {      my $lowest_load = 30000;
         my $lowest_load = 30000;      if (ref($offloadto) eq 'HASH') {
         if (ref($offloadto) eq 'HASH') {          if (ref($offloadto->{'primary'}) eq 'ARRAY') {
             if (ref($offloadto->{'primary'}) eq 'ARRAY') {              foreach my $try_server (@{$offloadto->{'primary'}}) {
                 foreach my $try_server (@{$offloadto->{'primary'}}) {                  ($otherserver,$lowest_load) =
                     ($otherserver,$lowest_load) =                      &compare_server_load($try_server,$otherserver,$lowest_load);
                         &compare_server_load($try_server,$otherserver,$lowest_load);  
                 }  
             }              }
             my $found_server = ($otherserver ne '' && $lowest_load < 100);          }
           my $found_server = ($otherserver ne '' && $lowest_load < 100);
   
             if (!$found_server) {          if (!$found_server) {
                 if (ref($offloadto->{'default'}) eq 'ARRAY') {              if (ref($offloadto->{'default'}) eq 'ARRAY') {
                     foreach my $try_server (@{$offloadto->{'default'}}) {                  foreach my $try_server (@{$offloadto->{'default'}}) {
                         ($otherserver,$lowest_load) =  
                             &compare_server_load($try_server,$otherserver,$lowest_load);  
                     }  
                 }  
             }  
         } elsif (ref($offloadto) eq 'ARRAY') {  
             if (@{$offloadto} == 1) {  
                 $otherserver = $offloadto->[0];  
             } elsif (@{$offloadto} > 1) {  
                 foreach my $try_server (@{$offloadto}) {  
                     ($otherserver,$lowest_load) =                      ($otherserver,$lowest_load) =
                         &compare_server_load($try_server,$otherserver,$lowest_load);                          &compare_server_load($try_server,$otherserver,$lowest_load);
                 }                  }
             }              }
         }          }
         if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {      } elsif (ref($offloadto) eq 'ARRAY') {
             $is_balancer = 0;          if (@{$offloadto} == 1) {
             if ($uname ne '' && $udom ne '') {              $otherserver = $offloadto->[0];
                 if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {          } elsif (@{$offloadto} > 1) {
               foreach my $try_server (@{$offloadto}) {
                     &appenv({'user.loadbalexempt'     => $lonhost,                  ($otherserver,$lowest_load) =
                              'user.loadbalcheck.time' => time});                      &compare_server_load($try_server,$otherserver,$lowest_load);
                 }  
             }              }
         }          }
     }      }
     return ($is_balancer,$otherserver);      return ($is_balancer,$otherserver);
 }  }
   
 sub check_balancer_result {  
     my ($result,@hosts) = @_;  
     my ($is_balancer,$currtargets,$currrules);  
     if (ref($result) eq 'HASH') {  
         if ($result->{'lonhost'} ne '') {  
             my $currbalancer = $result->{'lonhost'};  
             if (grep(/^\Q$currbalancer\E$/,@hosts)) {  
                 $is_balancer = 1;  
                 $currtargets = $result->{'targets'};  
                 $currrules = $result->{'rules'};  
             }  
         } else {  
             foreach my $key (keys(%{$result})) {  
                 if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&  
                     (ref($result->{$key}) eq 'HASH')) {  
                     $is_balancer = 1;  
                     $currrules = $result->{$key}{'rules'};  
                     $currtargets = $result->{$key}{'targets'};  
                     last;  
                 }  
             }  
         }  
     }  
     return ($is_balancer,$currtargets,$currrules);  
 }  
   
 sub get_loadbalancer_targets {  sub get_loadbalancer_targets {
     my ($rule_in_effect,$currtargets,$uname,$udom) = @_;      my ($rule_in_effect,$currtargets,$uname,$udom) = @_;
     my $offloadto;      my $offloadto;
     if ($rule_in_effect eq 'none') {      if ($rule_in_effect eq '') {
         return [$perlvar{'lonHostID'}];  
     } elsif ($rule_in_effect eq '') {  
         $offloadto = $currtargets;          $offloadto = $currtargets;
     } else {      } else {
         if ($rule_in_effect eq 'homeserver') {          if ($rule_in_effect eq 'homeserver') {
Line 1435  sub get_loadbalancer_targets { Line 1405  sub get_loadbalancer_targets {
                     }                      }
                 }                  }
             } else {              } else {
                 my %servers = &internet_dom_servers($udom);                  my %servers = &dom_servers($udom);
                 my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers);                  my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers);
                 if (&hostname($remotebalancer) ne '') {                  if (&hostname($remotebalancer) ne '') {
                     $offloadto = [$remotebalancer];                      $offloadto = [$remotebalancer];
Line 1954  sub get_domain_defaults { Line 1924  sub get_domain_defaults {
     my %domconfig =      my %domconfig =
          &Apache::lonnet::get_dom('configuration',['defaults','quotas',           &Apache::lonnet::get_dom('configuration',['defaults','quotas',
                                   'requestcourses','inststatus',                                    'requestcourses','inststatus',
                                   'coursedefaults','usersessions',                                    'coursedefaults','usersessions'],$domain);
                                   'requestauthor'],$domain);  
     if (ref($domconfig{'defaults'}) eq 'HASH') {      if (ref($domconfig{'defaults'}) eq 'HASH') {
         $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};           $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
         $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};          $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
Line 1974  sub get_domain_defaults { Line 1943  sub get_domain_defaults {
         } else {          } else {
             $domdefaults{'defaultquota'} = $domconfig{'quotas'};              $domdefaults{'defaultquota'} = $domconfig{'quotas'};
         }           } 
         my @usertools = ('aboutme','blog','webdav','portfolio');          my @usertools = ('aboutme','blog','portfolio');
         foreach my $item (@usertools) {          foreach my $item (@usertools) {
             if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {              if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
                 $domdefaults{$item} = $domconfig{'quotas'}{$item};                  $domdefaults{$item} = $domconfig{'quotas'}{$item};
Line 1986  sub get_domain_defaults { Line 1955  sub get_domain_defaults {
             $domdefaults{$item} = $domconfig{'requestcourses'}{$item};              $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
         }          }
     }      }
     if (ref($domconfig{'requestauthor'}) eq 'HASH') {  
         $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};  
     }  
     if (ref($domconfig{'inststatus'}) eq 'HASH') {      if (ref($domconfig{'inststatus'}) eq 'HASH') {
         foreach my $item ('inststatustypes','inststatusorder') {          foreach my $item ('inststatustypes','inststatusorder') {
             $domdefaults{$item} = $domconfig{'inststatus'}{$item};              $domdefaults{$item} = $domconfig{'inststatus'}{$item};
Line 2418  sub chatsend { Line 2384  sub chatsend {
   
 sub getversion {  sub getversion {
     my $fname=&clutter(shift);      my $fname=&clutter(shift);
     unless ($fname=~m{^(/adm/wrapper|)/res/}) { return -1; }      unless ($fname=~/^\/res\//) { return -1; }
     return &currentversion(&filelocation('',$fname));      return &currentversion(&filelocation('',$fname));
 }  }
   
Line 2605  sub ssi { Line 2571  sub ssi {
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
     my $response= $ua->request($request);      my $response= $ua->request($request);
       my $content = Encode::decode_utf8($response->content);
     if (wantarray) {      if (wantarray) {
  return ($response->content, $response);   return ($content, $response);
     } else {      } else {
  return $response->content;   return $content;
     }      }
 }  }
   
Line 2637  sub allowuploaded { Line 2604  sub allowuploaded {
     &Apache::lonnet::appenv(\%httpref);      &Apache::lonnet::appenv(\%httpref);
 }  }
   
 #  
 # Determine if the current user should be able to edit a particular resource,  
 # when viewing in course context.  
 # (a) When viewing resource used to determine if "Edit" item is included in  
 #     Functions.  
 # (b) When displaying folder contents in course editor, used to determine if  
 #     "Edit" link will be displayed alongside resource.  
 #  
 #  input: six args -- filename (decluttered), course number, course domain,  
 #                   url, symb (if registered) and group (if this is a group  
 #                   item -- e.g., bulletin board, group page etc.).  
 #  output: array of five scalars --  
 #          $cfile -- url for file editing if editable on current server  
 #          $home -- homeserver of resource (i.e., for author if published,  
 #                                           or course if uploaded.).  
 #          $switchserver --  1 if server switch will be needed.  
 #          $forceedit -- 1 if icon/link should be to go to edit mode  
 #          $forceview -- 1 if icon/link should be to go to view mode  
 #  
   
 sub can_edit_resource {  
     my ($file,$cnum,$cdom,$resurl,$symb,$group) = @_;  
     my ($cfile,$home,$switchserver,$forceedit,$forceview,$uploaded,$incourse);  
 #  
 # For aboutme pages user can only edit his/her own.  
 #  
     if ($resurl =~ m{^/?adm/($match_domain)/($match_username)/aboutme$}) {  
         my ($sdom,$sname) = ($1,$2);  
         if (($sdom eq $env{'user.domain'}) && ($sname eq $env{'user.name'})) {  
             $home = $env{'user.home'};  
             $cfile = $resurl;  
             if ($env{'form.forceedit'}) {  
                 $forceview = 1;  
             } else {  
                 $forceedit = 1;  
             }  
             return ($cfile,$home,$switchserver,$forceedit,$forceview);  
         } else {  
             return;  
         }  
     }  
   
     if ($env{'request.course.id'}) {  
         my $crsedit = &Apache::lonnet::allowed('mdc',$env{'request.course.id'});  
         if ($group ne '') {  
 # if this is a group homepage or group bulletin board, check group privs  
             my $allowed = 0;  
             if ($resurl =~ m{^/?adm/$cdom/$cnum/$group/smppg$}) {  
                 if ((&allowed('mdg',$env{'request.course.id'}.  
                               ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) ||  
                         (&allowed('mgh',$env{'request.course.id'}.'/'.$group)) || $crsedit) {  
                     $allowed = 1;  
                 }  
             } elsif ($resurl =~ m{^/?adm/$cdom/$cnum/\d+/bulletinboard$}) {  
                 if ((&allowed('mdg',$env{'request.course.id'}.($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) ||  
                         (&allowed('cgb',$env{'request.course.id'}.'/'.$group)) || $crsedit) {  
                     $allowed = 1;  
                 }  
             }  
             if ($allowed) {  
                 $home=&homeserver($cnum,$cdom);  
                 if ($env{'form.forceedit'}) {  
                     $forceview = 1;  
                 } else {  
                     $forceedit = 1;  
                 }  
                 $cfile = $resurl;  
             } else {  
                 return;  
             }  
         } else {  
 #  
 # No edit allowed where CC has switched to student role.  
 #  
             unless ($crsedit) {  
                 return;  
             }  
         }  
     }  
   
     if ($file ne '') {  
         if (($cnum =~ /$match_courseid/) && ($cdom =~ /$match_domain/)) {  
             if (&is_course_upload($file,$cnum,$cdom)) {  
                 $uploaded = 1;  
                 $incourse = 1;  
                 if ($file =~/\.(htm|html|css|js|txt)$/) {  
                     $cfile = &hreflocation('',$file);  
                     if ($env{'form.forceedit'}) {  
                         $forceview = 1;  
                     } else {  
                         $forceedit = 1;  
                     }  
                 }  
             } elsif ($resurl =~ m{^/public/$cdom/$cnum/syllabus}) {  
                 $incourse = 1;  
                 if ($env{'form.forceedit'}) {  
                     $forceview = 1;  
                 } else {  
                     $forceedit = 1;  
                 }  
                 $cfile = $resurl;  
             } elsif (($resurl ne '') && (&is_on_map($resurl))) {  
                 if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) {  
                     $incourse = 1;  
                     if ($env{'form.forceedit'}) {  
                         $forceview = 1;  
                     } else {  
                         $forceedit = 1;  
                     }  
                     $cfile = $resurl;  
                 } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem') {  
                     $incourse = 1;  
                     $cfile = $resurl.'/smpedit';  
                 } elsif ($resurl =~ m{^/adm/wrapper/ext/}) {  
                     $incourse = 1;  
                     if ($env{'form.forceedit'}) {  
                         $forceview = 1;  
                     } else {  
                         $forceedit = 1;  
                     }  
                     $cfile = $resurl;  
                 }  
             } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') {  
                 my $template = '/res/lib/templates/simpleproblem.problem';  
                 if (&is_on_map($template)) {  
                     $incourse = 1;  
                     $forceview = 1;  
                     $cfile = $template;  
                 }  
             } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) {  
                     $incourse = 1;  
                     if ($env{'form.forceedit'}) {  
                         $forceview = 1;  
                     } else {  
                         $forceedit = 1;  
                     }  
                     $cfile = $resurl;  
             } elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) {  
                 $incourse = 1;  
                 $forceview = 1;  
                 if ($symb) {  
                     my ($map,$id,$res)=&decode_symb($symb);  
                     $env{'request.symb'} = $symb;  
                     $cfile = &clutter($res);  
                 } else {  
                     $cfile = $env{'form.suppurl'};  
                     $cfile =~ s{^http://}{};  
                     $cfile = '/adm/wrapper/ext/'.$cfile;  
                 }  
             }  
         }  
         if ($uploaded || $incourse) {  
             $home=&homeserver($cnum,$cdom);  
         } elsif ($file !~ m{/$}) {  
             $file=~s{^(priv/$match_domain/$match_username)}{/$1};  
             $file=~s{^($match_domain/$match_username)}{/priv/$1};  
             # Check that the user has permission to edit this resource  
             my $setpriv = 1;  
             my ($cfuname,$cfudom)=&constructaccess($file,$setpriv);  
             if (defined($cfudom)) {  
                 $home=&homeserver($cfuname,$cfudom);  
                 $cfile=$file;  
             }  
         }  
         if (($cfile ne '') && (!$incourse || $uploaded) &&  
             (($home ne '') && ($home ne 'no_host'))) {  
             my @ids=&current_machine_ids();  
             unless (grep(/^\Q$home\E$/,@ids)) {  
                 $switchserver=1;  
             }  
         }  
     }  
     return ($cfile,$home,$switchserver,$forceedit,$forceview);  
 }  
   
 sub is_course_upload {  
     my ($file,$cnum,$cdom) = @_;  
     my $uploadpath = &LONCAPA::propath($cdom,$cnum);  
     $uploadpath =~ s{^\/}{};  
     if (($file =~ m{^\Q$uploadpath\E/userfiles/(docs|supplemental)/}) ||  
         ($file =~ m{^userfiles/\Q$cdom\E/\Q$cnum\E/(docs|supplemental)/})) {  
         return 1;  
     }  
     return;  
 }  
   
 sub in_course {  
     my ($udom,$uname,$cdom,$cnum,$type,$hideprivileged) = @_;  
     if ($hideprivileged) {  
         my $skipuser;  
         if (&privileged($uname,$udom)) {  
             $skipuser = 1;  
             my %coursehash = &coursedescription($cdom.'_'.$cnum);  
             if ($coursehash{'nothideprivileged'}) {  
                 foreach my $item (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {  
                     my $user;  
                     if ($item =~ /:/) {  
                         $user = $item;  
                     } else {  
                         $user = join(':',split(/[\@]/,$item));  
                     }  
                     if ($user eq $uname.':'.$udom) {  
                         undef($skipuser);  
                         last;  
                     }  
                 }  
             }  
             if ($skipuser) {  
                 return 0;  
             }  
         }  
     }  
     $type ||= 'any';  
     if (!defined($cdom) || !defined($cnum)) {  
         my $cid  = $env{'request.course.id'};  
         $cdom = $env{'course.'.$cid.'.domain'};  
         $cnum = $env{'course.'.$cid.'.num'};  
     }  
     my $typesref;  
     if (($type eq 'any') || ($type eq 'all')) {  
         $typesref = ['active','previous','future'];  
     } elsif ($type eq 'previous' || $type eq 'future') {  
         $typesref = [$type];  
     }  
     my %roles = &get_my_roles($uname,$udom,'userroles',  
                               $typesref,undef,[$cdom]);  
     my ($tmp) = keys(%roles);  
     return 0 if ($tmp =~ /^(con_lost|error|no_such_host)/i);  
     my @course_roles = grep(/^\Q$cnum\E:\Q$cdom\E:/, keys(%roles));  
     if (@course_roles > 0) {  
         return 1;  
     }  
     return 0;  
 }  
   
 # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course  # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
 # input: action, courseID, current domain, intended  # input: action, courseID, current domain, intended
 #        path to file, source of file, instruction to parse file for objects,  #        path to file, source of file, instruction to parse file for objects,
Line 3781  sub userrolelog { Line 3513  sub userrolelog {
   
 sub courserolelog {  sub courserolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;      my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;
     if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {      if (($trole eq 'cc') || ($trole eq 'in') ||
         my $cdom = $1;          ($trole eq 'ep') || ($trole eq 'ad') ||
         my $cnum = $2;          ($trole eq 'ta') || ($trole eq 'st') ||
         my $sec = $3;          ($trole=~/^cr/) || ($trole eq 'gr') ||
         my $namespace = 'rolelog';          ($trole eq 'co')) {
         my %storehash = (          if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
                            role    => $trole,              my $cdom = $1;
                            start   => $tstart,              my $cnum = $2;
                            end     => $tend,              my $sec = $3;
                            selfenroll => $selfenroll,              my $namespace = 'rolelog';
                            context    => $context,              my %storehash = (
                         );                                 role    => $trole,
         if ($trole eq 'gr') {                                 start   => $tstart,
             $namespace = 'groupslog';                                 end     => $tend,
             $storehash{'group'} = $sec;                                 selfenroll => $selfenroll,
         } else {                                 context    => $context,
             $storehash{'section'} = $sec;                              );
         }              if ($trole eq 'gr') {
         &write_log('course',$namespace,\%storehash,$delflag,$username,                  $namespace = 'groupslog';
                    $domain,$cnum,$cdom);                  $storehash{'group'} = $sec;
         if (($trole ne 'st') || ($sec ne '')) {              } else {
             &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);                  $storehash{'section'} = $sec;
               }
               &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);
               if (($trole ne 'st') || ($sec ne '')) {
                   &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);
               }
         }          }
     }      }
     return;      return;
 }  }
   
 sub domainrolelog {  
     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;  
     if ($area =~ m{^/($match_domain)/$}) {  
         my $cdom = $1;  
         my $domconfiguser = &Apache::lonnet::get_domainconfiguser($cdom);  
         my $namespace = 'rolelog';  
         my %storehash = (  
                            role    => $trole,  
                            start   => $tstart,  
                            end     => $tend,  
                            context => $context,  
                         );  
         &write_log('domain',$namespace,\%storehash,$delflag,$username,  
                    $domain,$domconfiguser,$cdom);  
     }  
     return;  
   
 }  
   
 sub coauthorrolelog {  
     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;  
     if ($area =~ m{^/($match_domain)/($match_username)$}) {  
         my $audom = $1;  
         my $auname = $2;  
         my $namespace = 'rolelog';  
         my %storehash = (  
                            role    => $trole,  
                            start   => $tstart,  
                            end     => $tend,  
                            context => $context,  
                         );  
         &write_log('author',$namespace,\%storehash,$delflag,$username,  
                    $domain,$auname,$audom);  
     }  
     return;  
 }  
   
 sub get_course_adv_roles {  sub get_course_adv_roles {
     my ($cid,$codes) = @_;      my ($cid,$codes) = @_;
     $cid=$env{'request.course.id'} unless (defined($cid));      $cid=$env{'request.course.id'} unless (defined($cid));
Line 3957  sub get_my_roles { Line 3657  sub get_my_roles {
         }          }
         my ($rolecode,$username,$domain,$section,$area);          my ($rolecode,$username,$domain,$section,$area);
         if ($context eq 'userroles') {          if ($context eq 'userroles') {
             ($area,$rolecode) = ($entry =~ /^(.+)_([^_]+)$/);              ($area,$rolecode) = split(/_/,$entry);
             (undef,$domain,$username,$section) = split(/\//,$area);              (undef,$domain,$username,$section) = split(/\//,$area);
         } else {          } else {
             ($role,$username,$domain,$section) = split(/\:/,$entry);              ($role,$username,$domain,$section) = split(/\:/,$entry);
Line 5279  sub delete_env_groupprivs { Line 4979  sub delete_env_groupprivs {
 sub check_adhoc_privs {  sub check_adhoc_privs {
     my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;      my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;
     my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;      my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
     my $setprivs;  
     if ($env{$cckey}) {      if ($env{$cckey}) {
         my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);          my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
         &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);          &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
         unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {          unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {
             &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);              &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
             $setprivs = 1;  
         }          }
     } else {      } else {
         &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);          &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
         $setprivs = 1;  
     }      }
     return $setprivs;  
 }  }
   
 sub set_adhoc_privileges {  sub set_adhoc_privileges {
Line 5678  sub tmpdel { Line 5374  sub tmpdel {
     return &reply("tmpdel:$token",$server);      return &reply("tmpdel:$token",$server);
 }  }
   
 # ------------------------------------------------------------ get_timebased_id  
   
 sub get_timebased_id {  
     my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries,  
         $maxtries) = @_;  
     my ($newid,$error,$dellock);  
     unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) {  
         return ('','ok','invalid call to get suffix');  
     }  
   
 # set defaults for any optional args for which values were not supplied  
     if ($who eq '') {  
         $who = $env{'user.name'}.':'.$env{'user.domain'};  
     }  
     if (!$locktries) {  
         $locktries = 3;  
     }  
     if (!$maxtries) {  
         $maxtries = 10;  
     }  
   
     if (($cdom eq '') || ($cnum eq '')) {  
         if ($env{'request.course.id'}) {  
             $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};  
             $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};  
         }  
         if (($cdom eq '') || ($cnum eq '')) {  
             return ('','ok','call to get suffix not in course context');  
         }  
     }  
   
 # construct locking item  
     my $lockhash = {  
                       $prefix."\0".'locked_'.$keyid => $who,  
                    };  
     my $tries = 0;  
   
 # attempt to get lock on nohist_$namespace file  
     my $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);  
     while (($gotlock ne 'ok') && $tries <$locktries) {  
         $tries ++;  
         sleep 1;  
         $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);  
     }  
   
 # attempt to get unique identifier, based on current timestamp  
     if ($gotlock eq 'ok') {  
         my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix);  
         my $id = time;  
         $newid = $id;  
         my $idtries = 0;  
         while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) {  
             if ($idtype eq 'concat') {  
                 $newid = $id.$idtries;  
             } else {  
                 $newid ++;  
             }  
             $idtries ++;  
         }  
         if (!exists($inuse{$prefix."\0".$newid})) {  
             my %new_item =  (  
                               $prefix."\0".$newid => $who,  
                             );  
             my $putresult = &Apache::lonnet::put('nohist_'.$namespace,\%new_item,  
                                                  $cdom,$cnum);  
             if ($putresult ne 'ok') {  
                 undef($newid);  
                 $error = 'error saving new item: '.$putresult;  
             }  
         } else {  
              $error = ('error: no unique suffix available for the new item ');  
         }  
 #  remove lock  
         my @del_lock = ($prefix."\0".'locked_'.$keyid);  
         $dellock = &Apache::lonnet::del('nohist_'.$namespace,\@del_lock,$cdom,$cnum);  
     } else {  
         $error = "error: could not obtain lockfile\n";  
         $dellock = 'ok';  
     }  
     return ($newid,$dellock,$error);  
 }  
   
 # -------------------------------------------------- portfolio access checking  # -------------------------------------------------- portfolio access checking
   
 sub portfolio_access {  sub portfolio_access {
Line 6015  sub usertools_access { Line 5629  sub usertools_access {
                       unofficial => 1,                        unofficial => 1,
                       community  => 1,                        community  => 1,
                  );                   );
     } elsif ($context eq 'requestauthor') {  
         %tools = (  
                       requestauthor => 1,  
                  );  
     } else {      } else {
         %tools = (          %tools = (
                       aboutme   => 1,                        aboutme   => 1,
                       blog      => 1,                        blog      => 1,
                       webdav    => 1,  
                       portfolio => 1,                        portfolio => 1,
                  );                   );
     }      }
Line 6038  sub usertools_access { Line 5647  sub usertools_access {
         if ($action ne 'reload') {          if ($action ne 'reload') {
             if ($context eq 'requestcourses') {              if ($context eq 'requestcourses') {
                 return $env{'environment.canrequest.'.$tool};                  return $env{'environment.canrequest.'.$tool};
             } elsif ($context eq 'requestauthor') {  
                 return $env{'environment.canrequest.author'};  
             } else {              } else {
                 return $env{'environment.availabletools.'.$tool};                  return $env{'environment.availabletools.'.$tool};
             }              }
         }          }
     }      }
   
     my ($toolstatus,$inststatus,$envkey);      my ($toolstatus,$inststatus);
     if ($context eq 'requestauthor') {  
         $envkey = $context;  
     } else {  
         $envkey = $context.'.'.$tool;  
     }  
   
     if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&      if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
          ($action ne 'reload')) {           ($action ne 'reload')) {
         $toolstatus = $env{'environment.'.$envkey};          $toolstatus = $env{'environment.'.$context.'.'.$tool};
         $inststatus = $env{'environment.inststatus'};          $inststatus = $env{'environment.inststatus'};
     } else {      } else {
         if (ref($userenvref) eq 'HASH') {          if (ref($userenvref) eq 'HASH') {
             $toolstatus = $userenvref->{$envkey};              $toolstatus = $userenvref->{$context.'.'.$tool};
             $inststatus = $userenvref->{'inststatus'};              $inststatus = $userenvref->{'inststatus'};
         } else {          } else {
             my %userenv = &userenvironment($udom,$uname,$envkey,'inststatus');              my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');
             $toolstatus = $userenv{$envkey};              $toolstatus = $userenv{$context.'.'.$tool};
             $inststatus = $userenv{'inststatus'};              $inststatus = $userenv{'inststatus'};
         }          }
     }      }
Line 6129  sub usertools_access { Line 5731  sub usertools_access {
             }              }
         }          }
     } else {      } else {
         if (($context eq 'tools') && ($tool ne 'webdav')) {          if ($context eq 'tools') {
             $access = 1;              $access = 1;
         } else {          } else {
             $access = 0;              $access = 0;
Line 6786  sub allowed { Line 6388  sub allowed {
    return 'F';     return 'F';
 }  }
   
 # ------------------------------------------- Check construction space access  
   
 sub constructaccess {  
     my ($url,$setpriv)=@_;  
   
 # We do not allow editing of previous versions of files  
     if ($url=~/\.(\d+)\.(\w+)$/) { return ''; }  
   
 # Get username and domain from URL  
     my ($ownername,$ownerdomain,$ownerhome);  
   
     ($ownerdomain,$ownername) =  
         ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)/});  
   
 # The URL does not really point to any authorspace, forget it  
     unless (($ownername) && ($ownerdomain)) { return ''; }  
   
 # Now we need to see if the user has access to the authorspace of  
 # $ownername at $ownerdomain  
   
     if (($ownername eq $env{'user.name'}) && ($ownerdomain eq $env{'user.domain'})) {  
 # Real author for this?  
        $ownerhome = $env{'user.home'};  
        if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) {  
           return ($ownername,$ownerdomain,$ownerhome);  
        }  
     } else {  
 # Co-author for this?  
         if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) ||  
             exists($env{'user.priv.aa./'.$ownerdomain.'/'.$ownername.'./'}) ) {  
             $ownerhome = &homeserver($ownername,$ownerdomain);  
             return ($ownername,$ownerdomain,$ownerhome);  
         }  
     }  
   
 # We don't have any access right now. If we are not possibly going to do anything about this,  
 # we might as well leave  
    unless ($setpriv) { return ''; }  
   
 # Backdoor access?  
     my $allowed=&allowed('eco',$ownerdomain);  
 # Nope  
     unless ($allowed) { return ''; }  
 # Looks like we may have access, but could be locked by the owner of the construction space  
     if ($allowed eq 'U') {  
         my %blocked=&get('environment',['domcoord.author'],  
                          $ownerdomain,$ownername);  
 # Is blocked by owner  
         if ($blocked{'domcoord.author'} eq 'blocked') { return ''; }  
     }  
     if (($allowed eq 'F') || ($allowed eq 'U')) {  
 # Grant temporary access  
         my $then=$env{'user.login.time'};  
         my $update==$env{'user.update.time'};  
         if (!$update) { $update = $then; }  
         my $refresh=$env{'user.refresh.time'};  
         if (!$refresh) { $refresh = $update; }  
         my $now = time;  
         &check_adhoc_privs($ownerdomain,$ownername,$update,$refresh,  
                            $now,'ca','constructaccess');  
         $ownerhome = &homeserver($ownername,$ownerdomain);  
         return($ownername,$ownerdomain,$ownerhome);  
     }  
 # No business here  
     return '';  
 }  
   
 sub get_comm_blocks {  sub get_comm_blocks {
     my ($cdom,$cnum) = @_;      my ($cdom,$cnum) = @_;
     if ($cdom eq '' || $cnum eq '') {      if ($cdom eq '' || $cnum eq '') {
Line 7917  sub assignrole { Line 7452  sub assignrole {
                             }                              }
                         }                          }
                     }                      }
                 } elsif ($context eq 'requestauthor') {  
                     if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&  
                         ($url eq '/'.$udom.'/') && ($role eq 'au')) {  
                         if ($env{'environment.requestauthor'} eq 'automatic') {  
                             $refused = '';  
                         } else {  
                             my %domdefaults = &get_domain_defaults($udom);  
                             if (ref($domdefaults{'requestauthor'}) eq 'HASH') {  
                                 my $checkbystatus;  
                                 if ($env{'user.adv'}) {  
                                     my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'};  
                                     if ($disposition eq 'automatic') {  
                                         $refused = '';  
                                     } elsif ($disposition eq '') {  
                                         $checkbystatus = 1;  
                                     }  
                                 } else {  
                                     $checkbystatus = 1;  
                                 }  
                                 if ($checkbystatus) {  
                                     if ($env{'environment.inststatus'}) {  
                                         my @inststatuses = split(/,/,$env{'environment.inststatus'});  
                                         foreach my $type (@inststatuses) {  
                                             if (($type ne '') &&  
                                                 ($domdefaults{'requestauthor'}{$type} eq 'automatic')) {  
                                                 $refused = '';  
                                             }  
                                         }  
                                     } elsif ($domdefaults{'requestauthor'}{'default'} eq 'automatic') {  
                                         $refused = '';  
                                     }  
                                 }  
                             }  
                         }  
                     }  
                 }                  }
                 if ($refused) {                  if ($refused) {
                     &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.                      &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
Line 8001  sub assignrole { Line 7501  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);
         if (($role eq 'cc') || ($role eq 'in') ||  
             ($role eq 'ep') || ($role eq 'ad') ||  
             ($role eq 'ta') || ($role eq 'st') ||  
             ($role=~/^cr/) || ($role eq 'gr') ||  
             ($role eq 'co')) {  
 # for course roles, perform group memberships changes triggered by role change.  # for course roles, perform group memberships changes triggered by role change.
             unless ($role =~ /^gr/) {          &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context);
                 &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,          unless ($role =~ /^gr/) {
                                                  $origstart,$selfenroll,$context);              &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
             }                                               $origstart,$selfenroll,$context);
             &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,  
                            $selfenroll,$context);  
         } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') ||  
                  ($role eq 'au') || ($role eq 'dc')) {  
             &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,  
                            $context);  
         } elsif (($role eq 'ca') || ($role eq 'aa')) {  
             &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,  
                              $context);  
         }          }
         if ($role eq 'cc') {          if ($role eq 'cc') {
             &autoupdate_coowners($url,$end,$start,$uname,$udom);              &autoupdate_coowners($url,$end,$start,$uname,$udom);
Line 10249  sub gettitle { Line 9735  sub gettitle {
     return $title;      return $title;
 }  }
   
 sub getdocspath {  
     my ($symb) = @_;  
     my $path;  
     if ($symb) {  
         my ($mapurl,$id,$resurl) = &decode_symb($symb);  
         if ($resurl=~/\.(sequence|page)$/) {  
             $mapurl=$resurl;  
         } elsif ($resurl eq 'adm/navmaps') {  
             $mapurl=$env{'course.'.$env{'request.course.id'}.'.url'};  
         }  
         my $mapresobj;  
         my $navmap = Apache::lonnavmaps::navmap->new();  
         if (ref($navmap)) {  
             $mapresobj = $navmap->getResourceByUrl($mapurl);  
         }  
         $mapurl=~s{^.*/([^/]+)\.(\w+)$}{$1};  
         my $type=$2;  
         if (ref($mapresobj)) {  
             my $pcslist = $mapresobj->map_hierarchy();  
             if ($pcslist ne '') {  
                 foreach my $pc (split(/,/,$pcslist)) {  
                     next if ($pc <= 1);  
                     my $res = $navmap->getByMapPc($pc);  
                     if (ref($res)) {  
                         my $thisurl = $res->src();  
                         $thisurl=~s{^.*/([^/]+)\.\w+$}{$1};  
                         my $thistitle = $res->title();  
                         $path .= '&'.  
                                  &Apache::lonhtmlcommon::entity_encode($thisurl).'&'.  
                                  &Apache::lonhtmlcommon::entity_encode($thistitle).  
                                  ':'.$res->randompick().  
                                  ':'.$res->randomout().  
                                  ':'.$res->encrypted().  
                                  ':'.$res->randomorder().  
                                  ':'.$res->is_page();  
                     }  
                 }  
             }  
             $path =~ s/^\&//;  
             my $maptitle = $mapresobj->title();  
             if ($mapurl eq 'default') {  
                 $maptitle = 'Main Course Documents';  
             }  
             $path .= ($path ne '')? '&' : ''.  
                     &Apache::lonhtmlcommon::entity_encode($mapurl).'&'.  
                     &Apache::lonhtmlcommon::entity_encode($maptitle).  
                     ':'.$mapresobj->randompick().  
                     ':'.$mapresobj->randomout().  
                     ':'.$mapresobj->encrypted().  
                     ':'.$mapresobj->randomorder().  
                     ':'.$mapresobj->is_page();  
         } else {  
             my $maptitle = &gettitle($mapurl);  
             my $ispage;  
             if ($mapurl =~ /\.page$/) {  
                 $ispage = 1;  
             }  
             if ($mapurl eq 'default') {  
                 $maptitle = 'Main Course Documents';  
             }  
             $path = &Apache::lonhtmlcommon::entity_encode($mapurl).'&'.  
                     &Apache::lonhtmlcommon::entity_encode($maptitle).':::::'.$ispage;  
         }  
         unless ($mapurl eq 'default') {  
             $path = 'default&'.  
                     &Apache::lonhtmlcommon::entity_encode('Main Course Documents').  
                     ':::::&'.$path;  
         }  
     }  
     return $path;  
 }  
   
 sub get_slot {  sub get_slot {
     my ($which,$cnum,$cdom)=@_;      my ($which,$cnum,$cdom)=@_;
     if (!$cnum || !$cdom) {      if (!$cnum || !$cdom) {
Line 10387  sub devalidate_slots_cache { Line 9801  sub devalidate_slots_cache {
     &devalidate_cache_new('allslots',$hashid);      &devalidate_cache_new('allslots',$hashid);
 }  }
   
 sub get_coursechange {  
     my ($cdom,$cnum) = @_;  
     if ($cdom eq '' || $cnum eq '') {  
         return unless ($env{'request.course.id'});  
         $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};  
         $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};  
     }  
     my $hashid=$cdom.'_'.$cnum;  
     my ($change,$cached)=&is_cached_new('crschange',$hashid);  
     if ((defined($cached)) && ($change ne '')) {  
         return $change;  
     } else {  
         my %crshash;  
         %crshash = &get('environment',['internal.contentchange'],$cdom,$cnum);  
         if ($crshash{'internal.contentchange'} eq '') {  
             $change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'};  
             if ($change eq '') {  
                 %crshash = &get('environment',['internal.created'],$cdom,$cnum);  
                 $change = $crshash{'internal.created'};  
             }  
         } else {  
             $change = $crshash{'internal.contentchange'};  
         }  
         my $cachetime = 600;  
         &do_cache_new('crschange',$hashid,$change,$cachetime);  
     }  
     return $change;  
 }  
   
 sub devalidate_coursechange_cache {  
     my ($cnum,$cdom)=@_;  
     my $hashid=$cnum.':'.$cdom;  
     &devalidate_cache_new('crschange',$hashid);  
 }  
   
 # ------------------------------------------------- Update symbolic store links  # ------------------------------------------------- Update symbolic store links
   
 sub symblist {  sub symblist {
Line 10449  sub symblist { Line 9828  sub symblist {
 # --------------------------------------------------------------- Verify a symb  # --------------------------------------------------------------- Verify a symb
   
 sub symbverify {  sub symbverify {
     my ($symb,$thisurl,$encstate)=@_;      my ($symb,$thisurl)=@_;
     my $thisfn=$thisurl;      my $thisfn=$thisurl;
     $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
Line 10468  sub symbverify { Line 9847  sub symbverify {
   
     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
         my $noclutter;  
         if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {          if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {
             $thisurl =~ s/\?.+$//;              $thisurl =~ s/\?.+$//;
             if ($map =~ m{^uploaded/.+\.page$}) {  
                 $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://};  
                 $thisurl =~ s{^\Qhttp://https://\E}{https://};  
                 $noclutter = 1;  
             }  
         }  
         my $ids;  
         if ($noclutter) {  
             $ids=$bighash{'ids_'.$thisurl};  
         } else {  
             $ids=$bighash{'ids_'.&clutter($thisurl)};  
         }          }
           my $ids=$bighash{'ids_'.&clutter($thisurl)};
         unless ($ids) {          unless ($ids) {
             my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;              my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;  
             $ids=$bighash{$idkey};              $ids=$bighash{$idkey};
         }          }
         if ($ids) {          if ($ids) {
 # ------------------------------------------------------------------- Has ID(s)  # ------------------------------------------------------------------- Has ID(s)
             if ($thisfn =~ m{^/adm/wrapper/ext/}) {  
                 $symb =~ s/\?.+$//;  
             }  
     foreach my $id (split(/\,/,$ids)) {      foreach my $id (split(/\,/,$ids)) {
        my ($mapid,$resid)=split(/\./,$id);         my ($mapid,$resid)=split(/\./,$id);
                  if ($thisfn =~ m{^/adm/wrapper/ext/}) {
                      $symb =~ s/\?.+$//;
                  }
                if (                 if (
   &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)    &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
    eq $symb) {     eq $symb) { 
                    if (ref($encstate)) {     if (($env{'request.role.adv'}) ||
                        $$encstate = $bighash{'encrypted_'.$id};         ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
                    }  
                    if (($env{'request.role.adv'}) ||  
                        ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||  
                        ($thisurl eq '/adm/navmaps')) {                         ($thisurl eq '/adm/navmaps')) {
                        $okay=1;         $okay=1; 
                        last;     }
                    }         }
                }     }
            }  
         }          }
  untie(%bighash);   untie(%bighash);
     }      }
Line 10580  sub deversion { Line 9944  sub deversion {
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse)=@_;      my ($thisfn,$donotrecurse)=@_;
     my $cache_str;      my $cache_str='request.symbread.cached.'.$thisfn;
     if ($thisfn ne '') {      if (defined($env{$cache_str})) { return $env{$cache_str}; }
         $cache_str='request.symbread.cached.'.$thisfn;  
         if ($env{$cache_str} ne '') {  
             return $env{$cache_str};  
         }  
    } else {  
 # no filename provided? try from environment  # no filename provided? try from environment
       unless ($thisfn) {
         if ($env{'request.symb'}) {          if ($env{'request.symb'}) {
             return $env{$cache_str}=&symbclean($env{'request.symb'});      return $env{$cache_str}=&symbclean($env{'request.symb'});
         }   }
         $thisfn=$env{'request.filename'};   $thisfn=$env{'request.filename'};
     }      }
     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }      if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
 # is that filename actually a symb? Verify, clean, and return  # is that filename actually a symb? Verify, clean, and return
Line 10819  sub rndseed { Line 10179  sub rndseed {
  $which =&get_rand_alg($courseid);   $which =&get_rand_alg($courseid);
     }      }
     if (defined(&getCODE())) {      if (defined(&getCODE())) {
   
  if ($which eq '64bit5') {   if ($which eq '64bit5') {
     return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);      return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
  } elsif ($which eq '64bit4') {   } elsif ($which eq '64bit4') {
Line 12367  allowed($priv,$uri,$symb,$role) : check Line 11728  allowed($priv,$uri,$symb,$role) : check
   
 =item *  =item *
   
 constructaccess($url,$setpriv) : check for access to construction space URL  
   
 See if the owner domain and name in the URL match those in the  
 expected environment.  If so, return three element list  
 ($ownername,$ownerdomain,$ownerhome).  
   
 Otherwise return the null string.  
   
 If second argument 'setpriv' is true, it assigns the privileges,  
 and returns the same three element list, unless the owner has  
 blocked "ad hoc" Domain Coordinator access to the Author Space,  
 in which case the null string is returned.  
   
 =item *  
   
 definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom  definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom
 role rolename set privileges in format of lonTabs/roles.tab for system, domain,  role rolename set privileges in format of lonTabs/roles.tab for system, domain,
 and course level  and course level
Line 12412  of role statuses (active, future or prev Line 11758  of role statuses (active, future or prev
 to restrict the list of roles reported. If no array ref is   to restrict the list of roles reported. If no array ref is 
 provided for types, will default to return only active roles.  provided for types, will default to return only active roles.
   
 =item *  
   
 in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if  
 user: $uname:$udom has a role in the course: $cdom_$cnum.  
   
 Additional optional arguments are: $type (if role checking is to be restricted  
 to certain user status types -- previous (expired roles), active (currently  
 available roles) or future (roles available in the future), and  
 $hideprivileged -- if true will not report course roles for users who  
 have active Domain Coordinator or Super User roles.  
   
 =back  =back
   
 =head2 User Modification  =head2 User Modification
Line 12625  data base, returning a hash that is keye Line 11960  data base, returning a hash that is keye
 values that are the resource value.  I believe that the timestamps and  values that are the resource value.  I believe that the timestamps and
 versions are also returned.  versions are also returned.
   
   
 =back  =back
   
 =head2 Course Modification  =head2 Course Modification
Line 12725  returns the data handle Line 12061  returns the data handle
   
 =item *  =item *
   
 symbverify($symb,$thisfn,$ecstate) : verifies that $symb actually exists  symbverify($symb,$thisfn) : verifies that $symb actually exists and is
 and is a possible symb for the URL in $thisfn, and if is an encrypted  a possible symb for the URL in $thisfn, and if is an encryypted
 resource that the user accessed using /enc/ returns a 1 on success, 0  resource that the user accessed using /enc/ returns a 1 on success, 0
 on failure, user must be in a course, as it assumes the existence of  on failure, user must be in a course, as it assumes the existance of
 the course initial hash, and uses $env('request.course.id'}.  The third  the course initial hash, and uses $env('request.course.id'}
 arg is an optional reference to a scalar.  If this arg is passed in the  
 call to symbverify, it will be set to 1 if the symb has been set to be   
 encrypted; otherwise it will be null.  
   
 =item *  =item *
   
Line 12785  expirespread($uname,$udom,$stype,$usymb) Line 12119  expirespread($uname,$udom,$stype,$usymb)
 devalidate($symb) : devalidate temporary spreadsheet calculations,  devalidate($symb) : devalidate temporary spreadsheet calculations,
 forcing spreadsheet to reevaluate the resource scores next time.  forcing spreadsheet to reevaluate the resource scores next time.
   
 =item *  
   
 can_edit_resource($file,$cnum,$cdom,$resurl,$symb,$group) : determine if current user can edit a particular resource,  
 when viewing in course context.  
   
  input: six args -- filename (decluttered), course number, course domain,  
                     url, symb (if registered) and group (if this is a  
                     group item -- e.g., bulletin board, group page etc.).  
   
  output: array of five scalars --  
          $cfile -- url for file editing if editable on current server  
          $home -- homeserver of resource (i.e., for author if published,  
                                           or course if uploaded.).  
          $switchserver --  1 if server switch will be needed.  
          $forceedit -- 1 if icon/link should be to go to edit mode  
          $forceview -- 1 if icon/link should be to go to view mode  
   
 =item *  
   
 is_course_upload($file,$cnum,$cdom)  
   
 Used in course context to determine if current file was uploaded to  
 the course (i.e., would be found in /userfiles/docs on the course's  
 homeserver.  
   
   input: 3 args -- filename (decluttered), course number and course domain.  
   output: boolean -- 1 if file was uploaded.  
   
 =back  =back
   
 =head2 Storing/Retreiving Data  =head2 Storing/Retreiving Data
Line 13368  Internal notes: Line 12674  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.
   
 =item *  
   
 modify_access_controls():  modify_access_controls():
   
 Modifies access controls for a portfolio file  Modifies access controls for a portfolio file
Line 13387  Returns: Line 12691  Returns:
 3. reference to hash of any new or updated access controls.  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.  4. reference to hash used to map incoming IDs to uniqueIDs assigned to control.
    key = integer (inbound ID)     key = integer (inbound ID)
    value = uniqueID     value = uniqueID  
   
 =item *  
   
 get_timebased_id():  
   
 Attempts to get a unique timestamp-based suffix for use with items added to a  
 course via the Course Editor (e.g., folders, composite pages,  
 group bulletin boards).  
   
 Args: (first three required; six others optional)  
   
 1. prefix (alphanumeric): of keys in hash, e.g., suppsequence, docspage,  
    docssequence, or name of group  
   
 2. keyid (alphanumeric): name of temporary locking key in hash,  
    e.g., num, boardids  
   
 3. namespace: name of gdbm file used to store suffixes already assigned;  
    file will be named nohist_namespace.db  
   
 4. cdom: domain of course; default is current course domain from %env  
   
 5. cnum: course number; default is current course number from %env  
   
 6. idtype: set to concat if an additional digit is to be appended to the  
    unix timestamp to form the suffix, if the plain timestamp is already  
    in use.  Default is to not do this, but simply increment the unix  
    timestamp by 1 until a unique key is obtained.  
   
 7. who: holder of locking key; defaults to user:domain for user.  
   
 8. locktries: number of attempts to obtain a lock (sleep of 1s before  
    retrying); default is 3.  
   
 9. maxtries: number of attempts to obtain a unique suffix; default is 20.  
   
 Returns:  
   
 1. suffix obtained (numeric)  
   
 2. result of deleting locking key (ok if deleted, or lock never obtained)  
   
 3. error: contains (localized) error message if an error occurred.  
   
   
 =back  =back
   
Removed from v.1.1172.2.14  
changed lines
  Added in v.1.1174

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