[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.25 and 1.1193

version 1.1172.2.25, 2013/05/23 14:36:44 version 1.1193, 2012/10/31 12:54:23
Line 75  use LWP::UserAgent(); Line 75  use LWP::UserAgent();
 use HTTP::Date;  use HTTP::Date;
 use Image::Magick;  use Image::Magick;
   
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $apache  
   use Encode;
   
   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 109  require Exporter; Line 112  require Exporter;
 our @ISA = qw (Exporter);  our @ISA = qw (Exporter);
 our @EXPORT = qw(%env);  our @EXPORT = qw(%env);
   
   
 # ------------------------------------ Logging (parameters, docs, slots, roles)  # ------------------------------------ Logging (parameters, docs, slots, roles)
 {  {
     my $logid;      my $logid;
Line 123  our @EXPORT = qw(%env); Line 127  our @EXPORT = qw(%env);
  $logid ++;   $logid ++;
         my $now = time();          my $now = time();
  my $id=$now.'00000'.$$.'00000'.$logid;   my $id=$now.'00000'.$$.'00000'.$logid;
         my $logentry = {          my $logentry = { 
                          $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,
                                 }                                    }
                        };                         };
         return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);   return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);
     }      }
 }  }
   
Line 630  sub check_for_valid_session { Line 634  sub check_for_valid_session {
  || !defined($disk_env{'user.domain'})) {   || !defined($disk_env{'user.domain'})) {
  return undef;   return undef;
     }      }
   
     if (($r->user() eq '') && ($apache >= 2.4)) {  
         if ($disk_env{'user.domain'} eq $r->dir_config('lonDefDomain')) {  
             $r->user($disk_env{'user.name'});  
         } else {  
             $r->user($disk_env{'user.name'}.':'.$disk_env{'user.domain'});  
         }  
     }  
   
     return $handle;      return $handle;
 }  }
   
Line 1271  sub check_loadbalancing { Line 1266  sub check_loadbalancing {
         }          }
     }      }
     if (ref($result) eq 'HASH') {      if (ref($result) eq 'HASH') {
         ($is_balancer,$currtargets,$currrules) =          ($is_balancer,$currtargets,$currrules) = 
             &check_balancer_result($result,@hosts);              &check_balancer_result($result,@hosts);
         if ($is_balancer) {          if ($is_balancer) {
             if (ref($currrules) eq 'HASH') {              if (ref($currrules) eq 'HASH') {
Line 1330  sub check_loadbalancing { Line 1325  sub check_loadbalancing {
             }              }
         }          }
         if (ref($result) eq 'HASH') {          if (ref($result) eq 'HASH') {
             ($is_balancer,$currtargets,$currrules) =              ($is_balancer,$currtargets,$currrules) = 
                 &check_balancer_result($result,@hosts);                  &check_balancer_result($result,@hosts);
             if ($is_balancer) {              if ($is_balancer) {
                 if (ref($currrules) eq 'HASH') {                  if (ref($currrules) eq 'HASH') {
Line 1386  sub check_loadbalancing { Line 1381  sub check_loadbalancing {
             $is_balancer = 0;              $is_balancer = 0;
             if ($uname ne '' && $udom ne '') {              if ($uname ne '' && $udom ne '') {
                 if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {                  if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
                       
                     &appenv({'user.loadbalexempt'     => $lonhost,                      &appenv({'user.loadbalexempt'     => $lonhost,  
                              'user.loadbalcheck.time' => time});                               'user.loadbalcheck.time' => time});
                 }                  }
             }              }
Line 2005  sub get_domain_defaults { Line 2000  sub get_domain_defaults {
         }          }
     }      }
     if (ref($domconfig{'coursedefaults'}) eq 'HASH') {      if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
         if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {          foreach my $item ('canuse_pdfforms') {
             $domdefaults{'officialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'official'};              $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};
             $domdefaults{'unofficialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'unofficial'};  
         }          }
     }      }
     if (ref($domconfig{'usersessions'}) eq 'HASH') {      if (ref($domconfig{'usersessions'}) eq 'HASH') {
Line 2018  sub get_domain_defaults { Line 2012  sub get_domain_defaults {
             $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};              $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};
         }          }
     }      }
     &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);      &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
                                     $cachetime);
     return %domdefaults;      return %domdefaults;
 }  }
   
Line 2615  sub ssi { Line 2610  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 = $response->content;
   
   
     if (wantarray) {      if (wantarray) {
  return ($response->content, $response);   return ($content, $response);
     } else {      } else {
  return $response->content;   return $content;
     }      }
 }  }
   
Line 2650  sub allowuploaded { Line 2648  sub allowuploaded {
 #  #
 # Determine if the current user should be able to edit a particular resource,  # Determine if the current user should be able to edit a particular resource,
 # when viewing in course context.  # when viewing in course context.
 # (a) When viewing resource used to determine if "Edit" item is included in  # (a) When viewing resource used to determine if "Edit" item is included in 
 #     Functions.  #     Functions.
 # (b) When displaying folder contents in course editor, used to determine if  # (b) When displaying folder contents in course editor, used to determine if
 #     "Edit" link will be displayed alongside resource.  #     "Edit" link will be displayed alongside resource.
 #  #
 #  input: six args -- filename (decluttered), course number, course domain,  #  input: 3 args -- filename (decluttered), course number and course domain.
 #                   url, symb (if registered) and group (if this is a group  #  output: array of four scalars -- 
 #                   item -- e.g., bulletin board, group page etc.).  
 #  output: array of five scalars --  
 #          $cfile -- url for file editing if editable on current server  #          $cfile -- url for file editing if editable on current server
 #          $home -- homeserver of resource (i.e., for author if published,  #          $home -- homeserver of resource (i.e., for author if published,
 #                                           or course if uploaded.).  #                                           or course if uploaded.).
 #          $switchserver --  1 if server switch will be needed.  #          $switchserver --  1 if server switch will be needed.
 #          $forceedit -- 1 if icon/link should be to go to edit mode  #          $uploaded -- 1 if resource is a file uploaded to a course.
 #          $forceview -- 1 if icon/link should be to go to view mode  
 #  #
   
 sub can_edit_resource {  sub can_edit_resource {
     my ($file,$cnum,$cdom,$resurl,$symb,$group) = @_;      my ($file,$cnum,$cdom) = @_;
     my ($cfile,$home,$switchserver,$forceedit,$forceview,$uploaded,$incourse);      my ($cfile,$home,$switchserver,$uploaded);
 #  
 # 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 {  
             if ($resurl =~ m{^/?adm/viewclasslist$}) {  
                 unless (&Apache::lonnet::allowed('opa',$env{'request.course.id'})) {  
                     return;  
                 }  
             } elsif (!$crsedit) {  
 #  
 # No edit allowed where CC has switched to student role.  
 #  
                 return;  
             }  
         }  
     }  
   
     if ($file ne '') {      if ($file ne '') {
         if (($cnum =~ /$match_courseid/) && ($cdom =~ /$match_domain/)) {          if (($cnum =~ /$match_courseid/) && ($cdom =~ /$match_domain/)) {
             if (&is_course_upload($file,$cnum,$cdom)) {              $uploaded = &is_course_upload($file,$cnum,$cdom);
                 $uploaded = 1;              if ($uploaded) {
                 $incourse = 1;                  $home=&homeserver($cnum,$cdom);
                 if ($file =~/\.(htm|html|css|js|txt)$/) {                  if ($file =~/\.(htm|html|css|js|txt)$/) {
                     $cfile = &hreflocation('',$file);                      $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 =~ m{^/?adm/viewclasslist$}) {  
                     $incourse = 1;  
                     if ($env{'form.forceedit'}) {  
                         $forceview = 1;  
                     } else {  
                         $forceedit = 1;  
                     }  
                     $cfile = ($resurl =~ m{^/} ? $resurl : "/$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) {          unless ($uploaded) {
             $home=&homeserver($cnum,$cdom);  
         } elsif ($file !~ m{/$}) {  
             $file=~s{^(priv/$match_domain/$match_username)}{/$1};              $file=~s{^(priv/$match_domain/$match_username)}{/$1};
             $file=~s{^($match_domain/$match_username)}{/priv/$1};              $file=~s{^($match_domain/$match_username)}{/priv/$1};
             # Check that the user has permission to edit this resource              # Check that the user has permission to edit this resource
Line 2823  sub can_edit_resource { Line 2686  sub can_edit_resource {
                 $cfile=$file;                  $cfile=$file;
             }              }
         }          }
         if (($cfile ne '') && (!$incourse || $uploaded) &&          if (($cfile ne '') && (($home ne '') && ($home ne 'no_host'))) {
             (($home ne '') && ($home ne 'no_host'))) {  
             my @ids=&current_machine_ids();              my @ids=&current_machine_ids();
             unless (grep(/^\Q$home\E$/,@ids)) {              unless (grep(/^\Q$home\E$/,@ids)) {
                 $switchserver=1;                  $switchserver=1;
             }              }
         }          }
     }      }
     return ($cfile,$home,$switchserver,$forceedit,$forceview);      return ($cfile,$home,$switchserver,$uploaded);
 }  }
   
 sub is_course_upload {  sub is_course_upload {
     my ($file,$cnum,$cdom) = @_;      my ($file,$cnum,$cdom) = @_;
     my $uploadpath = &LONCAPA::propath($cdom,$cnum);      my $uploadpath = &LONCAPA::propath($cdom,$cnum);
     $uploadpath =~ s{^\/}{};      $uploadpath =~ s{^\/}{};
     if (($file =~ m{^\Q$uploadpath\E/userfiles/(docs|supplemental)/}) ||      if (($file =~ m{^\Q$uploadpath\E/userfiles/docs/}) ||
         ($file =~ m{^userfiles/\Q$cdom\E/\Q$cnum\E/(docs|supplemental)/})) {          ($file =~ m{^userfiles/\Q$cdom\E/\Q$cnum\E/docs/})) {
         return 1;          return 1;
     }      }
     return;      return;
 }  }
   
 sub in_course {  
     my ($udom,$uname,$cdom,$cnum,$type,$hideprivileged) = @_;  
     if ($hideprivileged) {  
         my $skipuser;  
         my %coursehash = &coursedescription($cdom.'_'.$cnum);  
         my @possdoms = ($cdom);  
         if ($coursehash{'checkforpriv'}) {  
             push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));  
         }  
         if (&privileged($uname,$udom,\@possdoms)) {  
             $skipuser = 1;  
             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 3188  sub userfileupload { Line 2997  sub userfileupload {
  $codebase,$thumbwidth,$thumbheight,   $codebase,$thumbwidth,$thumbheight,
                                          $resizewidth,$resizeheight,$context,$mimetype);                                           $resizewidth,$resizeheight,$context,$mimetype);
         } else {          } else {
             if ($env{'form.folder'}) {              $fname=$env{'form.folder'}.'/'.$fname;
                 $fname=$env{'form.folder'}.'/'.$fname;  
             }  
             return &process_coursefile('uploaddoc',$docuname,$docudom,              return &process_coursefile('uploaddoc',$docuname,$docudom,
        $fname,$formname,$parser,         $fname,$formname,$parser,
        $allfiles,$codebase,$mimetype);         $allfiles,$codebase,$mimetype);
Line 3205  sub userfileupload { Line 3012  sub userfileupload {
     } else {      } else {
         my $docuname=$env{'user.name'};          my $docuname=$env{'user.name'};
         my $docudom=$env{'user.domain'};          my $docudom=$env{'user.domain'};
         if ((exists($env{'form.group'})) || ($context eq 'syllabus')) {          if (exists($env{'form.group'})) {
             $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};              $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
             $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};              $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
         }          }
Line 3355  sub extract_embedded_items { Line 3162  sub extract_embedded_items {
  &add_filetype($allfiles,$attr->{'src'},'src');   &add_filetype($allfiles,$attr->{'src'},'src');
     }      }
     if (lc($tagname) eq 'a') {      if (lc($tagname) eq 'a') {
                 unless (($attr->{'href'} =~ /^#/) || ($attr->{'href'} eq '')) {   &add_filetype($allfiles,$attr->{'href'},'href');
     &add_filetype($allfiles,$attr->{'href'},'href');  
                 }  
     }      }
             if (lc($tagname) eq 'script') {              if (lc($tagname) eq 'script') {
                 my $src;                  my $src;
Line 3888  sub get_course_adv_roles { Line 3693  sub get_course_adv_roles {
             $nothide{$user}=1;              $nothide{$user}=1;
         }          }
     }      }
     my @possdoms = ($coursehash{'domain'});  
     if ($coursehash{'checkforpriv'}) {  
         push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));  
     }  
     my %returnhash=();      my %returnhash=();
     my %dumphash=      my %dumphash=
             &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});              &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
Line 3904  sub get_course_adv_roles { Line 3705  sub get_course_adv_roles {
         if (($tstart) && ($now<$tstart)) { next; }          if (($tstart) && ($now<$tstart)) { next; }
         my ($role,$username,$domain,$section)=split(/\:/,$entry);          my ($role,$username,$domain,$section)=split(/\:/,$entry);
  if ($username eq '' || $domain eq '') { next; }   if ($username eq '' || $domain eq '') { next; }
         if ((&privileged($username,$domain,\@possdoms)) &&          unless (ref($privileged{$domain}) eq 'HASH') {
               my %dompersonnel =
                   &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
               $privileged{$domain} = {};
               foreach my $server (keys(%dompersonnel)) {
                   if (ref($dompersonnel{$server}) eq 'HASH') {
                       foreach my $user (keys(%{$dompersonnel{$server}})) {
                           my ($trole,$uname,$udom) = split(/:/,$user);
                           $privileged{$udom}{$uname} = 1;
                       }
                   }
               }
           }
           if ((exists($privileged{$domain}{$username})) && 
             (!$nothide{$username.':'.$domain})) { next; }              (!$nothide{$username.':'.$domain})) { next; }
  if ($role eq 'cr') { next; }   if ($role eq 'cr') { next; }
         if ($codes) {          if ($codes) {
Line 3935  sub get_my_roles { Line 3749  sub get_my_roles {
     if ($context eq 'userroles') {      if ($context eq 'userroles') {
         %dumphash = &dump('roles',$udom,$uname);          %dumphash = &dump('roles',$udom,$uname);
     } else {      } else {
         %dumphash = &dump('nohist_userroles',$udom,$uname);          %dumphash=
               &dump('nohist_userroles',$udom,$uname);
         if ($hidepriv) {          if ($hidepriv) {
             my %coursehash=&coursedescription($udom.'_'.$uname);              my %coursehash=&coursedescription($udom.'_'.$uname);
             foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {              foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
Line 4003  sub get_my_roles { Line 3818  sub get_my_roles {
             }              }
         }          }
         if ($hidepriv) {          if ($hidepriv) {
             my @privroles = ('dc','su');  
             if ($context eq 'userroles') {              if ($context eq 'userroles') {
                 next if (grep(/^\Q$role\E$/,@privroles));                  if ((&privileged($username,$domain)) &&
                       (!$nothide{$username.':'.$domain})) {
                       next;
                   }
             } else {              } else {
                 my $possdoms = [$domain];                  unless (ref($privileged{$domain}) eq 'HASH') {
                 if (ref($roledoms) eq 'ARRAY') {                      my %dompersonnel =
                    push(@{$possdoms},@{$roledoms});                          &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
                       $privileged{$domain} = {};
                       if (keys(%dompersonnel)) {
                           foreach my $server (keys(%dompersonnel)) {
                               if (ref($dompersonnel{$server}) eq 'HASH') {
                                   foreach my $user (keys(%{$dompersonnel{$server}})) {
                                       my ($trole,$uname,$udom) = split(/:/,$user);
                                       $privileged{$udom}{$uname} = $trole;
                                   }
                               }
                           }
                       }
                 }                  }
                 if (&privileged($username,$domain,$possdoms,\@privroles)) {                  if (exists($privileged{$domain}{$username})) {
                     if (!$nothide{$username.':'.$domain}) {                      if (!$nothide{$username.':'.$domain}) {
                         next;                          next;
                     }                      }
Line 4116  sub courseiddump { Line 3944  sub courseiddump {
     if (($domfilter eq '') ||      if (($domfilter eq '') ||
  (&host_domain($tryserver) eq $domfilter)) {   (&host_domain($tryserver) eq $domfilter)) {
                 my $rep;                  my $rep;
                 if (grep { $_ eq $tryserver } &current_machine_ids()) {                  if (grep { $_ eq $tryserver } current_machine_ids()) {
                     $rep = &LONCAPA::Lond::dump_course_id_handler(                      $rep = LONCAPA::Lond::dump_course_id_handler(
                         join(":", (&host_domain($tryserver), $sincefilter,                          join(":", (&host_domain($tryserver), $sincefilter, 
                                 &escape($descfilter), &escape($instcodefilter),                                  &escape($descfilter), &escape($instcodefilter), 
                                 &escape($ownerfilter), &escape($coursefilter),                                  &escape($ownerfilter), &escape($coursefilter),
                                 &escape($typefilter), &escape($regexp_ok),                                  &escape($typefilter), &escape($regexp_ok), 
                                 $as_hash, &escape($selfenrollonly),                                  $as_hash, &escape($selfenrollonly), 
                                 &escape($catfilter), $showhidden, $caller,                                  &escape($catfilter), $showhidden, $caller, 
                                 &escape($cloner), &escape($cc_clone), $cloneonly,                                  &escape($cloner), &escape($cc_clone), $cloneonly, 
                                 &escape($createdbefore), &escape($createdafter),                                  &escape($createdbefore), &escape($createdafter), 
                                 &escape($creationcontext), $domcloner)));                                  &escape($creationcontext), $domcloner)));
                 } else {                  } else {
                     $rep = &reply('courseiddump:'.&host_domain($tryserver).':'.                      $rep = &reply('courseiddump:'.&host_domain($tryserver).':'.
Line 4140  sub courseiddump { Line 3968  sub courseiddump {
                              &escape($creationcontext).':'.$domcloner,                               &escape($creationcontext).':'.$domcloner,
                              $tryserver);                               $tryserver);
                 }                  }
                        
                 my @pairs=split(/\&/,$rep);                  my @pairs=split(/\&/,$rep);
                 foreach my $item (@pairs) {                  foreach my $item (@pairs) {
                     my ($key,$value)=split(/\=/,$item,2);                      my ($key,$value)=split(/\=/,$item,2);
Line 4246  sub get_domain_roles { Line 4074  sub get_domain_roles {
     }      }
     my $rolelist;      my $rolelist;
     if (ref($roles) eq 'ARRAY') {      if (ref($roles) eq 'ARRAY') {
         $rolelist = join('&',@{$roles});          $rolelist = join(':',@{$roles});
     }      }
     my %personnel = ();      my %personnel = ();
   
Line 4925  sub update_released_required { Line 4753  sub update_released_required {
 # -------------------------------------------------See if a user is privileged  # -------------------------------------------------See if a user is privileged
   
 sub privileged {  sub privileged {
     my ($username,$domain,$possdomains,$possroles)=@_;      my ($username,$domain)=@_;
   
       my %rolesdump = &dump("roles", $domain, $username) or return 0;
     my $now = time;      my $now = time;
     my $roles;  
     if (ref($possroles) eq 'ARRAY') {  
         $roles = $possroles;  
     } else {  
         $roles = ['dc','su'];  
     }  
     if (ref($possdomains) eq 'ARRAY') {  
         my %privileged = &privileged_by_domain($possdomains,$roles);  
         foreach my $dom (@{$possdomains}) {  
             if (($username =~ /^$match_username$/) && ($domain =~ /^$match_domain$/) &&  
                 (ref($privileged{$dom}) eq 'HASH')) {  
                 foreach my $role (@{$roles}) {  
                     if (ref($privileged{$dom}{$role}) eq 'HASH') {  
                         if (exists($privileged{$dom}{$role}{$username.':'.$domain})) {  
                             my ($end,$start) = split(/:/,$privileged{$dom}{$role}{$username.':'.$domain});  
                             return 1 unless (($end && $end < $now) ||  
                                              ($start && $start > $now));  
                         }  
                     }  
                 }  
             }  
         }  
     } else {  
         my %rolesdump = &dump("roles", $domain, $username) or return 0;  
         my $now = time;  
   
         for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {      for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {
             my ($trole, $tend, $tstart) = split(/_/, $role);              my ($trole, $tend, $tstart) = split(/_/, $role);
             if (grep(/^\Q$trole\E$/,@{$roles})) {              if (($trole eq 'dc') || ($trole eq 'su')) {
                 return 1 unless ($tend && $tend < $now)                  return 1 unless ($tend && $tend < $now) 
                         or ($tstart && $tstart > $now);                      or ($tstart && $tstart > $now);
             }              }
         }   }
     }  
     return 0;  
 }  
   
 sub privileged_by_domain {      return 0;
     my ($domains,$roles) = @_;  
     my %privileged = ();  
     my $cachetime = 60*60*24;  
     my $now = time;  
     unless ((ref($domains) eq 'ARRAY') && (ref($roles) eq 'ARRAY')) {  
         return %privileged;  
     }  
     foreach my $dom (@{$domains}) {  
         next if (ref($privileged{$dom}) eq 'HASH');  
         my $needroles;  
         foreach my $role (@{$roles}) {  
             my ($result,$cached)=&is_cached_new('priv_'.$role,$dom);  
             if (defined($cached)) {  
                 if (ref($result) eq 'HASH') {  
                     $privileged{$dom}{$role} = $result;  
                 }  
             } else {  
                 $needroles = 1;  
             }  
         }  
         if ($needroles) {  
             my %dompersonnel = &get_domain_roles($dom,$roles);  
             $privileged{$dom} = {};  
             foreach my $server (keys(%dompersonnel)) {  
                 if (ref($dompersonnel{$server}) eq 'HASH') {  
                     foreach my $item (keys(%{$dompersonnel{$server}})) {  
                         my ($trole,$uname,$udom,$rest) = split(/:/,$item,4);  
                         my ($end,$start) = split(/:/,$dompersonnel{$server}{$item});  
                         next if ($end && $end < $now);  
                         $privileged{$dom}{$trole}{$uname.':'.$udom} =  
                             $dompersonnel{$server}{$item};  
                     }  
                 }  
             }  
             if (ref($privileged{$dom}) eq 'HASH') {  
                 foreach my $role (@{$roles}) {  
                     if (ref($privileged{$dom}{$role}) eq 'HASH') {  
                         &do_cache_new('priv_'.$role,$dom,$privileged{$dom}{$role},$cachetime);  
                     } else {  
                         my %hash = ();  
                         &do_cache_new('priv_'.$role,$dom,\%hash,$cachetime);  
                     }  
                 }  
             }  
         }  
     }  
     return %privileged;  
 }  }
   
 # -------------------------------------------------------- Get user privileges  # -------------------------------------------------------- Get user privileges
Line 5123  sub rolesinit { Line 4878  sub rolesinit {
 }  }
   
 sub set_arearole {  sub set_arearole {
     my ($trole,$area,$tstart,$tend,$domain,$username,$nolog) = @_;      my ($trole,$area,$tstart,$tend,$domain,$username) = @_;
     unless ($nolog) {  
 # log the associated role with the area  # log the associated role with the area
         &userrolelog($trole,$username,$domain,$area,$tstart,$tend);      &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
     }  
     return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);      return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);
 }  }
   
Line 5396  sub set_adhoc_privileges { Line 5149  sub set_adhoc_privileges {
     my $area = '/'.$dcdom.'/'.$pickedcourse;      my $area = '/'.$dcdom.'/'.$pickedcourse;
     my $spec = $role.'.'.$area;      my $spec = $role.'.'.$area;
     my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},      my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
                                   $env{'user.name'},1);                                    $env{'user.name'});
     my %ccrole = ();      my %ccrole = ();
     &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);      &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);
     my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);      my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);
Line 5465  sub unserialize { Line 5218  sub unserialize {
     return {} if $rep =~ /^error/;      return {} if $rep =~ /^error/;
   
     my %returnhash=();      my %returnhash=();
     foreach my $item (split(/\&/,$rep)) {   foreach my $item (split /\&/, $rep) {
         my ($key, $value) = split(/=/, $item, 2);      my ($key, $value) = split(/=/, $item, 2);
         $key = unescape($key) unless $escapedkeys;      $key = unescape($key) unless $escapedkeys;
         next if $key =~ /^error: 2 /;      next if $key =~ /^error: 2 /;
         $returnhash{$key} = &thaw_unescape($value);      $returnhash{$key} = Apache::lonnet::thaw_unescape($value);
     }   }
       #return %returnhash;
     return \%returnhash;      return \%returnhash;
 }  }        
   
 # see Lond::dump_with_regexp  # see Lond::dump_with_regexp
 # if $escapedkeys hash keys won't get unescaped.  # if $escapedkeys hash keys won't get unescaped.
Line 5483  sub dump { Line 5237  sub dump {
     my $uhome=&homeserver($uname,$udomain);      my $uhome=&homeserver($uname,$udomain);
   
     my $reply;      my $reply;
     if (grep { $_ eq $uhome } &current_machine_ids()) {      if (grep { $_ eq $uhome } current_machine_ids()) {
         # user is hosted on this machine          # user is hosted on this machine
         $reply = LONCAPA::Lond::dump_with_regexp(join(':', ($udomain,          $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain,
                     $uname, $namespace, $regexp, $range)), $loncaparevs{$uhome});                      $uname, $namespace, $regexp, $range)), $loncaparevs{$uhome});
         return %{&unserialize($reply, $escapedkeys)};          return %{unserialize($reply, $escapedkeys)};
     }      }
     if ($regexp) {      if ($regexp) {
  $regexp=&escape($regexp);   $regexp=&escape($regexp);
Line 5500  sub dump { Line 5254  sub dump {
     if (!($rep =~ /^error/ )) {      if (!($rep =~ /^error/ )) {
  foreach my $item (@pairs) {   foreach my $item (@pairs) {
     my ($key,$value)=split(/=/,$item,2);      my ($key,$value)=split(/=/,$item,2);
             $key = &unescape($key) unless ($escapedkeys);          $key = unescape($key) unless $escapedkeys;
           #$key = &unescape($key);
     next if ($key =~ /^error: 2 /);      next if ($key =~ /^error: 2 /);
     $returnhash{$key}=&thaw_unescape($value);      $returnhash{$key}=&thaw_unescape($value);
  }   }
Line 5541  sub currentdump { Line 5296  sub currentdump {
    $sdom     = $env{'user.domain'}       if (! defined($sdom));     $sdom     = $env{'user.domain'}       if (! defined($sdom));
    $sname    = $env{'user.name'}         if (! defined($sname));     $sname    = $env{'user.name'}         if (! defined($sname));
    my $uhome = &homeserver($sname,$sdom);     my $uhome = &homeserver($sname,$sdom);
    my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);     my $rep;
   
      if (grep { $_ eq $uhome } current_machine_ids()) {
          $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname, 
                      $courseid)));
      } else {
          $rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
      }
   
    return if ($rep =~ /^(error:|no_such_host)/);     return if ($rep =~ /^(error:|no_such_host)/);
    #     #
    my %returnhash=();     my %returnhash=();
Line 5784  sub tmpdel { Line 5547  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 6154  sub usertools_access { Line 5835  sub usertools_access {
   
     my ($toolstatus,$inststatus,$envkey);      my ($toolstatus,$inststatus,$envkey);
     if ($context eq 'requestauthor') {      if ($context eq 'requestauthor') {
         $envkey = $context;          $envkey = $context; 
     } else {      } else {
         $envkey = $context.'.'.$tool;          $envkey = $context.'.'.$tool;
     }      }
Line 6945  sub constructaccess { Line 6626  sub constructaccess {
     if (($allowed eq 'F') || ($allowed eq 'U')) {      if (($allowed eq 'F') || ($allowed eq 'U')) {
 # Grant temporary access  # Grant temporary access
         my $then=$env{'user.login.time'};          my $then=$env{'user.login.time'};
         my $update=$env{'user.update.time'};          my $update==$env{'user.update.time'};
         if (!$update) { $update = $then; }          if (!$update) { $update = $then; }
         my $refresh=$env{'user.refresh.time'};          my $refresh=$env{'user.refresh.time'};
         if (!$refresh) { $refresh = $update; }          if (!$refresh) { $refresh = $update; }
Line 7484  sub auto_validate_instcode { Line 7165  sub auto_validate_instcode {
     }      }
     $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.      $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
                         &escape($instcode).':'.&escape($owner),$homeserver));                          &escape($instcode).':'.&escape($owner),$homeserver));
     my ($outcome,$description,$defaultcredits) = map { &unescape($_); } split('&',$response,3);      my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);
     return ($outcome,$description,$defaultcredits);      return ($outcome,$description);
 }  }
   
 sub auto_create_password {  sub auto_create_password {
Line 8024  sub assignrole { Line 7705  sub assignrole {
                         }                          }
                     }                      }
                 } elsif ($context eq 'requestauthor') {                  } elsif ($context eq 'requestauthor') {
                     if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&                      if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && 
                         ($url eq '/'.$udom.'/') && ($role eq 'au')) {                          ($url eq '/'.$udom.'/') && ($role eq 'au')) {
                         if ($env{'environment.requestauthor'} eq 'automatic') {                          if ($env{'environment.requestauthor'} eq 'automatic') {
                             $refused = '';                              $refused = '';
Line 8032  sub assignrole { Line 7713  sub assignrole {
                             my %domdefaults = &get_domain_defaults($udom);                              my %domdefaults = &get_domain_defaults($udom);
                             if (ref($domdefaults{'requestauthor'}) eq 'HASH') {                              if (ref($domdefaults{'requestauthor'}) eq 'HASH') {
                                 my $checkbystatus;                                  my $checkbystatus;
                                 if ($env{'user.adv'}) {                                  if ($env{'user.adv'}) { 
                                     my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'};                                      my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'};
                                     if ($disposition eq 'automatic') {                                      if ($disposition eq 'automatic') {
                                         $refused = '';                                          $refused = '';
                                     } elsif ($disposition eq '') {                                      } elsif ($disposition eq '') {
                                         $checkbystatus = 1;                                          $checkbystatus = 1;
                                     }                                      } 
                                 } else {                                  } else {
                                     $checkbystatus = 1;                                      $checkbystatus = 1;
                                 }                                  }
Line 8107  sub assignrole { Line 7788  sub assignrole {
 # log new user role if status is ok  # log new user role if status is ok
     if ($answer eq 'ok') {      if ($answer eq 'ok') {
  &userrolelog($role,$uname,$udom,$url,$start,$end);   &userrolelog($role,$uname,$udom,$url,$start,$end);
   # for course roles, perform group memberships changes triggered by role change.
           unless ($role =~ /^gr/) {
               &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
                                                $origstart,$selfenroll,$context);
           }
         if (($role eq 'cc') || ($role eq 'in') ||          if (($role eq 'cc') || ($role eq 'in') ||
             ($role eq 'ep') || ($role eq 'ad') ||              ($role eq 'ep') || ($role eq 'ad') ||
             ($role eq 'ta') || ($role eq 'st') ||              ($role eq 'ta') || ($role eq 'st') ||
             ($role=~/^cr/) || ($role eq 'gr') ||              ($role=~/^cr/) || ($role eq 'gr') ||
             ($role eq 'co')) {              ($role eq 'co')) {
 # for course roles, perform group memberships changes triggered by role change.  
             unless ($role =~ /^gr/) {  
                 &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,  
                                                  $origstart,$selfenroll,$context);  
             }  
             &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,              &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                            $selfenroll,$context);                             $selfenroll,$context);
         } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') ||          } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') ||
Line 8125  sub assignrole { Line 7806  sub assignrole {
                            $context);                             $context);
         } elsif (($role eq 'ca') || ($role eq 'aa')) {          } elsif (($role eq 'ca') || ($role eq 'aa')) {
             &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,              &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                              $context);                               $context); 
         }          }
         if ($role eq 'cc') {          if ($role eq 'cc') {
             &autoupdate_coowners($url,$end,$start,$uname,$udom);              &autoupdate_coowners($url,$end,$start,$uname,$udom);
Line 8425  sub modifyuser { Line 8106  sub modifyuser {
 sub modifystudent {  sub modifystudent {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,      my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
         $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,          $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
         $selfenroll,$context,$inststatus,$credits)=@_;          $selfenroll,$context,$inststatus)=@_;
     if (!$cid) {      if (!$cid) {
  unless ($cid=$env{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
     return 'not_in_class';      return 'not_in_class';
Line 8440  sub modifystudent { Line 8121  sub modifystudent {
     # students environment      # students environment
     $uid = undef if (!$forceid);      $uid = undef if (!$forceid);
     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,      $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
  $gene,$usec,$end,$start,$type,$locktype,   $gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context);
                                         $cid,$selfenroll,$context,$credits);  
     return $reply;      return $reply;
 }  }
   
 sub modify_student_enrollment {  sub modify_student_enrollment {
     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,      my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context) = @_;
         $locktype,$cid,$selfenroll,$context,$credits) = @_;  
     my ($cdom,$cnum,$chome);      my ($cdom,$cnum,$chome);
     if (!$cid) {      if (!$cid) {
  unless ($cid=$env{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
Line 8494  sub modify_student_enrollment { Line 8173  sub modify_student_enrollment {
     my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);      my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);
     my $reply=cput('classlist',      my $reply=cput('classlist',
    {$user =>      {$user => 
  join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits) },   join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
    $cdom,$cnum);     $cdom,$cnum);
     if (($reply eq 'ok') || ($reply eq 'delayed')) {      if (($reply eq 'ok') || ($reply eq 'delayed')) {
         &devalidate_getsection_cache($udom,$uname,$cid);          &devalidate_getsection_cache($udom,$uname,$cid);
Line 8723  sub is_course { Line 8402  sub is_course {
     my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,      my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,
         '.');          '.');
   
     return unless(exists($courses{$cdom.'_'.$cnum}));      return unless exists($courses{$cdom.'_'.$cnum});
     return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;      return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
 }  }
   
Line 9979  sub metadata { Line 9658  sub metadata {
     # if it is a non metadata possible uri return quickly      # if it is a non metadata possible uri return quickly
     if (($uri eq '') ||       if (($uri eq '') || 
  (($uri =~ m|^/*adm/|) &&    (($uri =~ m|^/*adm/|) && 
      ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard)$})) ||       ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
  return undef;   return undef;
     }      }
Line 10410  sub get_course_slots { Line 10089  sub get_course_slots {
         my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum);          my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum);
         my ($tmp) = keys(%slots);          my ($tmp) = keys(%slots);
         if ($tmp !~ /^(con_lost|error|no_such_host)/i) {          if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
             &do_cache_new('allslots',$hashid,\%slots,600);              &Apache::lonnet::do_cache_new('allslots',$hashid,\%slots,600);
             return %slots;              return %slots;
         }          }
     }      }
Line 10504  sub symbverify { Line 10183  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 (ref($encstate)) {
                        $$encstate = $bighash{'encrypted_'.$id};                         $$encstate = $bighash{'encrypted_'.$id};
                    }                     }
                    if (($env{'request.role.adv'}) ||     if (($env{'request.role.adv'}) ||
                        ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||         ($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 10616  sub deversion { Line 10283  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})) {
         $cache_str='request.symbread.cached.'.$thisfn;          if (($thisfn) || ($env{$cache_str} ne '')) {
         if ($env{$cache_str} ne '') {  
             return $env{$cache_str};              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 10855  sub rndseed { Line 10522  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 11537  sub goodbye { Line 11205  sub goodbye {
 }  }
   
 sub get_dns {  sub get_dns {
     my ($url,$func,$ignore_cache,$nocache,$hashref) = @_;      my ($url,$func,$ignore_cache) = @_;
     if (!$ignore_cache) {      if (!$ignore_cache) {
  my ($content,$cached)=   my ($content,$cached)=
     &Apache::lonnet::is_cached_new('dns',$url);      &Apache::lonnet::is_cached_new('dns',$url);
  if ($cached) {   if ($cached) {
     &$func($content,$hashref);      &$func($content);
     return;      return;
  }   }
     }      }
Line 11567  sub get_dns { Line 11235  sub get_dns {
         delete($alldns{$dns});          delete($alldns{$dns});
  next if ($response->is_error());   next if ($response->is_error());
  my @content = split("\n",$response->content);   my @content = split("\n",$response->content);
         unless ($nocache) {   &Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60);
     &do_cache_new('dns',$url,\@content,30*24*60*60);   &$func(\@content);
         }  
  &$func(\@content,$hashref);  
  return;   return;
     }      }
     close($config);      close($config);
Line 11578  sub get_dns { Line 11244  sub get_dns {
     &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");      &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
     open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");      open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");
     my @content = <$config>;      my @content = <$config>;
     &$func(\@content,$hashref);      &$func(\@content);
     return;  
 }  
   
 # ------------------------------------------------------Get DNS checksums file  
 sub parse_dns_checksums_tab {  
     my ($lines,$hashref) = @_;  
     my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});  
     my $loncaparev = &get_server_loncaparev($machine_dom);  
     my ($release,$timestamp) = split(/\-/,$loncaparev);  
     my (%chksum,%revnum);  
     if (ref($lines) eq 'ARRAY') {  
         chomp(@{$lines});  
         my $versions = shift(@{$lines});  
         my %supported;  
         if ($versions =~ /^VERSIONS\:([\w\.\,]+)$/) {  
             my $releaseslist = $1;  
             if ($releaseslist =~ /,/) {  
                 map { $supported{$_} = 1; } split(/,/,$releaseslist);  
             } elsif ($releaseslist) {  
                 $supported{$releaseslist} = 1;  
             }  
         }  
         if ($supported{$release}) {  
             my $matchthis = 0;  
             foreach my $line (@{$lines}) {  
                 if ($line =~ /^(\d[\w\.]+)$/) {  
                     if ($matchthis) {  
                         last;  
                     } elsif ($1 eq $release) {  
                         $matchthis = 1;  
                     }  
                 } elsif ($matchthis) {  
                     my ($file,$version,$shasum) = split(/,/,$line);  
                     $chksum{$file} = $shasum;  
                     $revnum{$file} = $version;  
                 }  
             }  
             if (ref($hashref) eq 'HASH') {  
                 %{$hashref} = (  
                                 sums     => \%chksum,  
                                 versions => \%revnum,  
                               );  
             }  
         }  
     }  
     return;      return;
 }  }
   
 sub fetch_dns_checksums {  
     my %checksums;  
     &get_dns('/adm/dns/checksums',\&parse_dns_checksums_tab,1,1,  
              \%checksums);  
     return \%checksums;  
 }  
   
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
 {  {
     my $loaded;      my $loaded;
Line 11943  sub fetch_dns_checksums { Line 11556  sub fetch_dns_checksums {
     }      }
     push(@{$iphost{$ip}},@{$name_to_host{$name}});      push(@{$iphost{$ip}},@{$name_to_host{$name}});
  }   }
  &do_cache_new('iphost','iphost',   &Apache::lonnet::do_cache_new('iphost','iphost',
       [\%iphost,\%name_to_ip,\%lonid_to_ip],        [\%iphost,\%name_to_ip,\%lonid_to_ip],
       48*60*60);        48*60*60);
   
  return %iphost;   return %iphost;
     }      }
Line 12001  sub fetch_dns_checksums { Line 11614  sub fetch_dns_checksums {
             }              }
             $seen{$prim_ip} = 1;              $seen{$prim_ip} = 1;
         }          }
         return &do_cache_new('internetnames',$lonid,\@idns,12*60*60);          return &Apache::lonnet::do_cache_new('internetnames',$lonid,\@idns,12*60*60);
     }      }
   
 }  }
Line 12171  $readit=1; Line 11784  $readit=1;
  if ($test != 0) { $_64bit=1; } else { $_64bit=0; }   if ($test != 0) { $_64bit=1; } else { $_64bit=0; }
  &logthis(" Detected 64bit platform ($_64bit)");   &logthis(" Detected 64bit platform ($_64bit)");
     }      }
   
     {  
         eval {  
             ($apache) =  
                 (Apache2::ServerUtil::get_server_version() =~ m{Apache/(\d+\.\d+)});  
         };  
         if ($@) {  
            $apache = 1.3;  
         }  
     }  
   
 }  }
 }  }
   
Line 12500  environment).  If no custom name is defi Line 12102  environment).  If no custom name is defi
         
 =item *  =item *
   
 get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv) :  get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) :
 All arguments are optional. Returns a hash of a roles, either for  All arguments are optional. Returns a hash of a roles, either for
 co-author/assistant author roles for a user's Construction Space  co-author/assistant author roles for a user's Construction Space
 (default), or if $context is 'userroles', roles for the user himself,  (default), or if $context is 'userroles', roles for the user himself,
Line 12514  of role statuses (active, future or prev Line 12116  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 role in course's domain or in additional  
 domains (specified in 'Domains to check for privileged users' in course  
 environment -- set via:  Course Settings -> Classlists and staff listing).  
   
 =item *  
   
 privileged($username,$domain,$possdomains,$possroles) : returns 1 if user  
 $username:$domain is a privileged user (e.g., Domain Coordinator or Super User)  
 $possdomains and $possroles are optional array refs -- to domains to check and  
 roles to check.  If $possdomains is not specified, a dump will be done of the  
 users' roles.db to check for a dc or su role in any domain. This can be  
 time consuming if &privileged is called repeatedly (e.g., when displaying a  
 classlist), so in such cases, supplying a $possdomains array is preferred, as  
 this then allows &privileged_by_domain() to be used, which caches the identity  
 of privileged users, eliminating the need for repeated calls to &dump().  
   
 =item *  
   
 privileged_by_domain($possdomains,$roles) : returns a hash of a hash of a hash,  
 where the outer hash keys are domains specified in the $possdomains array ref,  
 next inner hash keys are privileged roles specified in the $roles array ref,  
 and the innermost hash contains key = value pairs for username:domain = end:start  
 for active or future "privileged" users with that role in that domain. To avoid  
 repeated dumps of domain roles -- via &get_domain_roles() -- contents of the  
 innerhash are cached using priv_$role and $dom as the identifiers.  
   
 =back  =back
   
 =head2 User Modification  =head2 User Modification
Line 12641  Inputs: Line 12208  Inputs:
   
 =item B<$context> role change context (shown in User Management Logs display in a course)  =item B<$context> role change context (shown in User Management Logs display in a course)
   
 =item B<$inststatus> institutional status of user - : separated string of escaped status types  =item B<$inststatus> institutional status of user - : separated string of escaped status types  
   
 =item B<$credits> Number of credits student will earn from this class - only needs to be supplied if value needs to be different from default credits for class.  
   
 =back  =back
   
Line 12688  Inputs: Line 12253  Inputs:
   
 =item $context  =item $context
   
 =item $credits, number of credits student will earn from this class  
   
 =back  =back
   
   
Line 12755  data base, returning a hash that is keye Line 12318  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 12860  and is a possible symb for the URL in $t Line 12424  and is a possible symb for the URL in $t
 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 existence of
 the course initial hash, and uses $env('request.course.id'}.  The third  the course initial hash, and uses $env('request.course.id'}.  The third
 arg is an optional reference to a scalar.  If this arg is passed in the  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   call to symbverify, it will be set to 1 if the symb has been set to be 
 encrypted; otherwise it will be null.  encrypted; otherwise it will be null.  
   
 =item *  =item *
   
Line 12915  expirespread($uname,$udom,$stype,$usymb) Line 12479  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 13498  Internal notes: Line 13034  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 13517  Returns: Line 13051  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.25  
changed lines
  Added in v.1.1193

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