[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.31 and 1.1231

version 1.1172.2.31, 2013/08/08 02:09:10 version 1.1231, 2013/07/25 19:11:12
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 $apache  use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $apache
             $_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 (($r->user() eq '') && ($apache >= 2.4)) {
         if ($disk_env{'user.domain'} eq $r->dir_config('lonDefDomain')) {          if ($disk_env{'user.domain'} eq $r->dir_config('lonDefDomain')) {
             $r->user($disk_env{'user.name'});              $r->user($disk_env{'user.name'});
Line 638  sub check_for_valid_session { Line 641  sub check_for_valid_session {
             $r->user($disk_env{'user.name'}.':'.$disk_env{'user.domain'});              $r->user($disk_env{'user.name'}.':'.$disk_env{'user.domain'});
         }          }
     }      }
   
     return $handle;      return $handle;
 }  }
   
Line 1271  sub check_loadbalancing { Line 1273  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 1332  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 1388  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 1576  sub idput { Line 1578  sub idput {
     }      }
 }  }
   
 # ---------------------------------------- Delete unwanted IDs from ids.db file  # ---------------------------------------- Delete unwanted IDs from ids.db file 
   
 sub iddel {  sub iddel {
     my ($udom,$idshashref,$uhome)=@_;      my ($udom,$idshashref,$uhome)=@_;
Line 2038  sub get_domain_defaults { Line 2040  sub get_domain_defaults {
         }          }
     }      }
     if (ref($domconfig{'coursedefaults'}) eq 'HASH') {      if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
           $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};
         if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {          if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
             $domdefaults{'officialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'official'};              $domdefaults{'officialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'official'};
             $domdefaults{'unofficialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'unofficial'};              $domdefaults{'unofficialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'unofficial'};
Line 2045  sub get_domain_defaults { Line 2048  sub get_domain_defaults {
         if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {          if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
             $domdefaults{'officialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'official'};              $domdefaults{'officialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'official'};
             $domdefaults{'unofficialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'unofficial'};              $domdefaults{'unofficialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'unofficial'};
             $domdefaults{'communityquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'community'};              $domdefaults{'communityquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'community'};           
         }          }
     }      }
     if (ref($domconfig{'usersessions'}) eq 'HASH') {      if (ref($domconfig{'usersessions'}) eq 'HASH') {
Line 2653  sub ssi { Line 2656  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 2688  sub allowuploaded { Line 2694  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.
Line 2696  sub allowuploaded { Line 2702  sub allowuploaded {
 #  input: six args -- filename (decluttered), course number, course domain,  #  input: six args -- filename (decluttered), course number, course domain,
 #                   url, symb (if registered) and group (if this is a group  #                   url, symb (if registered) and group (if this is a group
 #                   item -- e.g., bulletin board, group page etc.).  #                   item -- e.g., bulletin board, group page etc.).
 #  output: array of five scalars --  #  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  #          $forceedit -- 1 if icon/link should be to go to edit mode 
 #          $forceview -- 1 if icon/link should be to go to view mode  #          $forceview -- 1 if icon/link should be to go to view mode
 #  #
   
Line 2790  sub can_edit_resource { Line 2796  sub can_edit_resource {
                     $forceedit = 1;                      $forceedit = 1;
                 }                  }
                 $cfile = $resurl;                  $cfile = $resurl;
             } elsif (($resurl ne '') && (&is_on_map($resurl))) {              } elsif (($resurl ne '') && (&is_on_map($resurl))) { 
                 if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) {                  if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) {
                     $incourse = 1;                      $incourse = 1;
                     if ($env{'form.forceedit'}) {                      if ($env{'form.forceedit'}) {
Line 2821  sub can_edit_resource { Line 2827  sub can_edit_resource {
                 }                  }
             } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') {              } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') {
                 my $template = '/res/lib/templates/simpleproblem.problem';                  my $template = '/res/lib/templates/simpleproblem.problem';
                 if (&is_on_map($template)) {                  if (&is_on_map($template)) { 
                     $incourse = 1;                      $incourse = 1;
                     $forceview = 1;                      $forceview = 1;
                     $cfile = $template;                      $cfile = $template;
Line 2846  sub can_edit_resource { Line 2852  sub can_edit_resource {
                     $cfile =~ s{^http://}{};                      $cfile =~ s{^http://}{};
                     $cfile = '/adm/wrapper/ext/'.$cfile;                      $cfile = '/adm/wrapper/ext/'.$cfile;
                 }                  }
             } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {  
                 if ($env{'form.forceedit'}) {  
                     $forceview = 1;  
                 } else {  
                     $forceedit = 1;  
                 }  
                 $cfile = ($resurl =~ m{^/} ? $resurl : "/$resurl");  
             }              }
         }          }
         if ($uploaded || $incourse) {          if ($uploaded || $incourse) {
Line 2868  sub can_edit_resource { Line 2867  sub can_edit_resource {
                 $cfile=$file;                  $cfile=$file;
             }              }
         }          }
         if (($cfile ne '') && (!$incourse || $uploaded) &&          if (($cfile ne '') && (!$incourse || $uploaded) && 
             (($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)) {
Line 2895  sub in_course { Line 2894  sub in_course {
     if ($hideprivileged) {      if ($hideprivileged) {
         my $skipuser;          my $skipuser;
         my %coursehash = &coursedescription($cdom.'_'.$cnum);          my %coursehash = &coursedescription($cdom.'_'.$cnum);
         my @possdoms = ($cdom);          my @possdoms = ($cdom);  
         if ($coursehash{'checkforpriv'}) {          if ($coursehash{'checkforpriv'}) { 
             push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));              push(@possdoms,split(/,/,$coursehash{'checkforpriv'})); 
         }          }
         if (&privileged($uname,$udom,\@possdoms)) {          if (&privileged($uname,$udom,\@possdoms)) {
             $skipuser = 1;              $skipuser = 1;
Line 3401  sub extract_embedded_items { Line 3400  sub extract_embedded_items {
     }      }
     if (lc($tagname) eq 'a') {      if (lc($tagname) eq 'a') {
                 unless (($attr->{'href'} =~ /^#/) || ($attr->{'href'} eq '')) {                  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') {
Line 4054  sub get_my_roles { Line 4053  sub get_my_roles {
             } else {              } else {
                 my $possdoms = [$domain];                  my $possdoms = [$domain];
                 if (ref($roledoms) eq 'ARRAY') {                  if (ref($roledoms) eq 'ARRAY') {
                    push(@{$possdoms},@{$roledoms});                     push(@{$possdoms},@{$roledoms}); 
                 }                  }
                 if (&privileged($username,$domain,$possdoms,\@privroles)) {                  if (&privileged($username,$domain,$possdoms,\@privroles)) {
                     if (!$nothide{$username.':'.$domain}) {                      if (!$nothide{$username.':'.$domain}) {
Line 4161  sub courseiddump { Line 4160  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 4185  sub courseiddump { Line 4184  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 4977  sub privileged { Line 4976  sub privileged {
     my $now = time;      my $now = time;
     my $roles;      my $roles;
     if (ref($possroles) eq 'ARRAY') {      if (ref($possroles) eq 'ARRAY') {
         $roles = $possroles;          $roles = $possroles; 
     } else {      } else {
         $roles = ['dc','su'];          $roles = ['dc','su'];
     }      }
Line 5004  sub privileged { Line 5003  sub privileged {
         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 (grep(/^\Q$trole\E$/,@{$roles})) {
                 return 1 unless ($tend && $tend < $now)                  return 1 unless ($tend && $tend < $now) 
                         or ($tstart && $tstart > $now);                          or ($tstart && $tstart > $now);
             }              }
         }          }
Line 5042  sub privileged_by_domain { Line 5041  sub privileged_by_domain {
                         my ($trole,$uname,$udom,$rest) = split(/:/,$item,4);                          my ($trole,$uname,$udom,$rest) = split(/:/,$item,4);
                         my ($end,$start) = split(/:/,$dompersonnel{$server}{$item});                          my ($end,$start) = split(/:/,$dompersonnel{$server}{$item});
                         next if ($end && $end < $now);                          next if ($end && $end < $now);
                         $privileged{$dom}{$trole}{$uname.':'.$udom} =                          $privileged{$dom}{$trole}{$uname.':'.$udom} = 
                             $dompersonnel{$server}{$item};                              $dompersonnel{$server}{$item};
                     }                      }
                 }                  }
Line 5513  sub unserialize { Line 5512  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 5531  sub dump { Line 5531  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)), $perlvar{'lonVersion'});                      $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
         return %{&unserialize($reply, $escapedkeys)};          return %{unserialize($reply, $escapedkeys)};
     }      }
     if ($regexp) {      if ($regexp) {
  $regexp=&escape($regexp);   $regexp=&escape($regexp);
Line 5548  sub dump { Line 5548  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 5589  sub currentdump { Line 5590  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 5832  sub tmpdel { Line 5841  sub tmpdel {
     return &reply("tmpdel:$token",$server);      return &reply("tmpdel:$token",$server);
 }  }
   
 # ------------------------------------------------------------ get_timebased_id  # ------------------------------------------------------------ get_timebased_id 
   
 sub get_timebased_id {  sub get_timebased_id {
     my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries,      my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries,
         $maxtries) = @_;          $maxtries) = @_;
     my ($newid,$error,$dellock);      my ($newid,$error,$dellock);
     unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) {      unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) {  
         return ('','ok','invalid call to get suffix');          return ('','ok','invalid call to get suffix');
     }      }
   
Line 5852  sub get_timebased_id { Line 5861  sub get_timebased_id {
     if (!$maxtries) {      if (!$maxtries) {
         $maxtries = 10;          $maxtries = 10;
     }      }
       
     if (($cdom eq '') || ($cnum eq '')) {      if (($cdom eq '') || ($cnum eq '')) {
         if ($env{'request.course.id'}) {          if ($env{'request.course.id'}) {
             $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};              $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
Line 6202  sub usertools_access { Line 6211  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 8072  sub assignrole { Line 8081  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 8080  sub assignrole { Line 8089  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 8173  sub assignrole { Line 8182  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 8485  sub modifystudent { Line 8494  sub modifystudent {
          $desiredhome,$email,$inststatus);           $desiredhome,$email,$inststatus);
     unless ($reply eq 'ok') { return $reply; }      unless ($reply eq 'ok') { return $reply; }
     # This will cause &modify_student_enrollment to get the uid from the      # This will cause &modify_student_enrollment to get the uid from the
     # student's 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,$credits);                                          $cid,$selfenroll,$context,$credits);
     return $reply;      return $reply;
 }  }
Line 9621  sub resdata { Line 9630  sub resdata {
     return undef;      return undef;
 }  }
   
 sub get_numsuppfiles {  
     my ($cnum,$cdom,$ignorecache)=@_;  
     my $hashid=$cnum.':'.$cdom;  
     my ($suppcount,$cached);  
     unless ($ignorecache) {  
         ($suppcount,$cached) = &is_cached_new('suppcount',$hashid);  
     }  
     unless (defined($cached)) {  
         my $chome=&homeserver($cnum,$cdom);  
         unless ($chome eq 'no_host') {  
             ($suppcount,my $errors) = (0,0);  
             my $suppmap = 'supplemental.sequence';  
             ($suppcount,$errors) =  
                 &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);  
         }  
         &do_cache_new('suppcount',$hashid,$suppcount,600);  
     }  
     return $suppcount;  
 }  
   
 #  #
 # EXT resource caching routines  # EXT resource caching routines
 #  #
Line 9784  sub EXT { Line 9773  sub EXT {
     if (!$symbparm) { $symbparm=&symbread(); }      if (!$symbparm) { $symbparm=&symbread(); }
  }   }
   
         if ($qualifier eq '') {   if ($space eq 'title') {
     if ($space eq 'title') {      if (!$symbparm) { $symbparm = $env{'request.filename'}; }
         if (!$symbparm) { $symbparm = $env{'request.filename'}; }      return &gettitle($symbparm);
         return &gettitle($symbparm);   }
     }  
   
     if ($space eq 'map') {   if ($space eq 'map') {
         my ($map) = &decode_symb($symbparm);      my ($map) = &decode_symb($symbparm);
         return &symbread($map);      return &symbread($map);
     }   }
             if ($space eq 'maptitle') {   if ($space eq 'filename') {
                 my ($map) = &decode_symb($symbparm);      if ($symbparm) {
                 return &gettitle($map);   return &clutter((&decode_symb($symbparm))[2]);
             }  
     if ($space eq 'filename') {  
         if ($symbparm) {  
     return &clutter((&decode_symb($symbparm))[2]);  
         }  
         return &hreflocation('',$env{'request.filename'});  
     }      }
       return &hreflocation('',$env{'request.filename'});
             if ((defined($courseid)) && ($courseid eq $env{'request.course.id'}) && $symbparm) {   }
                 if ($space eq 'visibleparts') {  
                     my $navmap = Apache::lonnavmaps::navmap->new();  
                     my $item;  
                     if (ref($navmap)) {  
                         my $res = $navmap->getBySymb($symbparm);  
                         my $parts = $res->parts();  
                         if (ref($parts) eq 'ARRAY') {  
                             $item = join(',',@{$parts});  
                         }  
                         undef($navmap);  
                     }  
                     return $item;  
                 }  
             }  
         }  
   
  my ($section, $group, @groups);   my ($section, $group, @groups);
  my ($courselevelm,$courselevel);   my ($courselevelm,$courselevel);
Line 9828  sub EXT { Line 9795  sub EXT {
             $courseid = $cid;              $courseid = $cid;
         }          }
  if (($symbparm && $courseid) &&    if (($symbparm && $courseid) && 
     (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid))) {      (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid)))  {
   
     #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;      #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
   
Line 10616  sub symbverify { Line 10583  sub symbverify {
             $ids=$bighash{'ids_'.&clutter($thisurl)};              $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) {
Line 10632  sub symbverify { Line 10599  sub symbverify {
                    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;                         last;
                    }     }
                }         }
            }     }
         }          }
  untie(%bighash);   untie(%bighash);
     }      }
Line 10718  sub symbread { Line 10685  sub symbread {
         if ($env{$cache_str} ne '') {          if ($env{$cache_str} ne '') {
             return $env{$cache_str};              return $env{$cache_str};
         }          }
    } else {      } else {
 # no filename provided? try from environment  # no filename provided? try from environment
         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 10951  sub rndseed { Line 10918  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 11663  sub get_dns { Line 11631  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) {   unless ($nocache) {
     &do_cache_new('dns',$url,\@content,30*24*60*60);      &do_cache_new('dns',$url,\@content,30*24*60*60);
         }   }
  &$func(\@content,$hashref);   &$func(\@content,$hashref);
  return;   return;
     }      }
Line 11697  sub parse_dns_checksums_tab { Line 11665  sub parse_dns_checksums_tab {
                 $supported{$releaseslist} = 1;                  $supported{$releaseslist} = 1;
             }              }
         }          }
         if ($supported{$release}) {          if ($supported{$release}) {  
             my $matchthis = 0;              my $matchthis = 0;
             foreach my $line (@{$lines}) {              foreach my $line (@{$lines}) {
                 if ($line =~ /^(\d[\w\.]+)$/) {                  if ($line =~ /^(\d[\w\.]+)$/) {
Line 11724  sub parse_dns_checksums_tab { Line 11692  sub parse_dns_checksums_tab {
 }  }
   
 sub fetch_dns_checksums {  sub fetch_dns_checksums {
     my %checksums;      my %checksums; 
     &get_dns('/adm/dns/checksums',\&parse_dns_checksums_tab,1,1,      &get_dns('/adm/dns/checksums',\&parse_dns_checksums_tab,1,1,
              \%checksums);               \%checksums);
     return \%checksums;      return \%checksums;
Line 12106  sub all_loncaparevs { Line 12074  sub all_loncaparevs {
     return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10);      return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10);
 }  }
   
 # ------------------------------------------------------- Read loncaparev table  # ---------------------------------------------------------- Read loncaparev table
 {  {
     sub load_loncaparevs {      sub load_loncaparevs { 
         if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {          if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {
             if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {              if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {
                 while (my $configline=<$config>) {                  while (my $configline=<$config>) {
Line 12122  sub all_loncaparevs { Line 12090  sub all_loncaparevs {
     }      }
 }  }
   
 # ----------------------------------------------------- Read serverhostID table  # ---------------------------------------------------------- Read serverhostID table
 {  {
     sub load_serverhomeIDs {      sub load_serverhomeIDs {
         if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {          if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {
Line 12214  BEGIN { Line 12182  BEGIN {
     close($config);      close($config);
 }  }
   
 # --------------------------------------------------------- Read loncaparev table  # ---------------------------------------------------------- Read loncaparev table
   
 &load_loncaparevs();  &load_loncaparevs();
   
 # ------------------------------------------------------- Read serverhostID table  # ---------------------------------------------------------- Read serverhostID table
   
 &load_serverhomeIDs();  &load_serverhomeIDs();
   
Line 12627  provided for types, will default to retu Line 12595  provided for types, will default to retu
 =item *  =item *
   
 in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if  in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if
 user: $uname:$udom has a role in the course: $cdom_$cnum.  user: $uname:$udom has a role in the course: $cdom_$cnum. 
   
 Additional optional arguments are: $type (if role checking is to be restricted  Additional optional arguments are: $type (if role checking is to be restricted 
 to certain user status types -- previous (expired roles), active (currently  to certain user status types -- previous (expired roles), active (currently
 available roles) or future (roles available in the future), and  available roles) or future (roles available in the future), and
 $hideprivileged -- if true will not report course roles for users who  $hideprivileged -- if true will not report course roles for users who
Line 12700  or when Autoupdate.pl is run by cron in Line 12668  or when Autoupdate.pl is run by cron in
 modifystudent  modifystudent
   
 modify a student's enrollment and identification information.  modify a student's enrollment and identification information.
 The course id is resolved based on the current user's environment.    The course id is resolved based on the current users environment.  
 This means the invoking user must be a course coordinator or otherwise  This means the envoking user must be a course coordinator or otherwise
 associated with a course.  associated with a course.
   
 This call is essentially a wrapper for lonnet::modifyuser and  This call is essentially a wrapper for lonnet::modifyuser and
Line 12761  Inputs: Line 12729  Inputs:
   
 modify_student_enrollment  modify_student_enrollment
   
 Change a student's enrollment status in a class.  The environment variable  Change a students enrollment status in a class.  The environment variable
 'role.request.course' must be defined for this function to proceed.  'role.request.course' must be defined for this function to proceed.
   
 Inputs:  Inputs:
   
 =over 4  =over 4
   
 =item $udom, student's domain  =item $udom, students domain
   
 =item $uname, student's name  =item $uname, students name
   
 =item $uid, student's user id  =item $uid, students user id
   
 =item $first, student's first name  =item $first, students first name
   
 =item $middle  =item $middle
   
Line 12856  If defined, the supplied username is use Line 12824  If defined, the supplied username is use
 resdata($name,$domain,$type,@which) : request for current parameter  resdata($name,$domain,$type,@which) : request for current parameter
 setting for a specific $type, where $type is either 'course' or 'user',  setting for a specific $type, where $type is either 'course' or 'user',
 @what should be a list of parameters to ask about. This routine caches  @what should be a list of parameters to ask about. This routine caches
 answers for 10 minutes.  answers for 5 minutes.
   
 =item *  =item *
   
Line 12865  data base, returning a hash that is keye Line 12833  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.
   
 get_numsuppfiles($cnum,$cdom) : retrieve number of files in a course's  
 supplemental content area. This routine caches the number of files for  
 10 minutes.  
   
 =back  =back
   
 =head2 Course Modification  =head2 Course Modification
Line 12979  and is a possible symb for the URL in $t Line 12943  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 13034  expirespread($uname,$udom,$stype,$usymb) Line 12998  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 *  =item * 
   
 can_edit_resource($file,$cnum,$cdom,$resurl,$symb,$group) : determine if current user can edit a particular resource,  can_edit_resource($file,$cnum,$cdom,$resurl,$symb,$group) : determine if current user can edit a particular resource,
 when viewing in course context.  when viewing in course context.
   
  input: six args -- filename (decluttered), course number, course domain,   input: six args -- filename (decluttered), course number, course domain,
                     url, symb (if registered) and group (if this is a                      url, symb (if registered) and group (if this is a 
                     group item -- e.g., bulletin board, group page etc.).                      group item -- e.g., bulletin board, group page etc.).
   
  output: array of five scalars --   output: array of five scalars --
Line 13048  when viewing in course context. Line 13012  when viewing in course context.
          $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           $forceedit -- 1 if icon/link should be to go to edit mode 
          $forceview -- 1 if icon/link should be to go to view mode           $forceview -- 1 if icon/link should be to go to view mode
   
 =item *  =item *
   
 is_course_upload($file,$cnum,$cdom)  is_course_upload($file,$cnum,$cdom)
   
 Used in course context to determine if current file was uploaded to  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  the course (i.e., would be found in /userfiles/docs on the course's 
 homeserver.  homeserver.
   
   input: 3 args -- filename (decluttered), course number and course domain.    input: 3 args -- filename (decluttered), course number and course domain.
Line 13642  Returns: Line 13606  Returns:
   
 get_timebased_id():  get_timebased_id():
   
 Attempts to get a unique timestamp-based suffix for use with items added to a  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,  course via the Course Editor (e.g., folders, composite pages, 
 group bulletin boards).  group bulletin boards).
   
 Args: (first three required; six others optional)  Args: (first three required; six others optional)
Line 13654  Args: (first three required; six others Line 13618  Args: (first three required; six others
 2. keyid (alphanumeric): name of temporary locking key in hash,  2. keyid (alphanumeric): name of temporary locking key in hash,
    e.g., num, boardids     e.g., num, boardids
   
 3. namespace: name of gdbm file used to store suffixes already assigned;  3. namespace: name of gdbm file used to store suffixes already assigned;  
    file will be named nohist_namespace.db     file will be named nohist_namespace.db
   
 4. cdom: domain of course; default is current course domain from %env  4. cdom: domain of course; default is current course domain from %env
   
 5. cnum: course number; default is current course number 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  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     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     in use.  Default is to not do this, but simply increment the unix 
    timestamp by 1 until a unique key is obtained.     timestamp by 1 until a unique key is obtained.
   
 7. who: holder of locking key; defaults to user:domain for user.  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  8. locktries: number of attempts to obtain a lock (sleep of 1s before 
    retrying); default is 3.     retrying); default is 3.
   
 9. maxtries: number of attempts to obtain a unique suffix; default is 20.  9. maxtries: number of attempts to obtain a unique suffix; default is 20.  
   
 Returns:  Returns:
   
Removed from v.1.1172.2.31  
changed lines
  Added in v.1.1231

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