[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.1303 and 1.1314

version 1.1303, 2016/03/04 21:43:33 version 1.1314, 2016/07/24 14:35:29
Line 1288  sub check_loadbalancing { Line 1288  sub check_loadbalancing {
     my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);      my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);
     my $intdom = &Apache::lonnet::internet_dom($lonhost);      my $intdom = &Apache::lonnet::internet_dom($lonhost);
     my $serverhomedom = &host_domain($lonhost);      my $serverhomedom = &host_domain($lonhost);
       my $domneedscache;
     my $cachetime = 60*60*24;      my $cachetime = 60*60*24;
   
     if (($uintdom ne '') && ($uintdom eq $intdom)) {      if (($uintdom ne '') && ($uintdom eq $intdom)) {
Line 1303  sub check_loadbalancing { Line 1303  sub check_loadbalancing {
             &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use);              &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use);
         if (ref($domconfig{'loadbalancing'}) eq 'HASH') {          if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
             $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);              $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
           } else {
               $domneedscache = $dom_in_use;
         }          }
     }      }
     if (ref($result) eq 'HASH') {      if (ref($result) eq 'HASH') {
Line 1361  sub check_loadbalancing { Line 1363  sub check_loadbalancing {
             my %domconfig =              my %domconfig =
                 &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);                  &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);
             if (ref($domconfig{'loadbalancing'}) eq 'HASH') {              if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
                 $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);                  $result = &do_cache_new('loadbalancing',$serverhomedom,$domconfig{'loadbalancing'},$cachetime);
               } else {
                   $domneedscache = $serverhomedom;
             }              }
         }          }
         if (ref($result) eq 'HASH') {          if (ref($result) eq 'HASH') {
Line 1381  sub check_loadbalancing { Line 1385  sub check_loadbalancing {
                 $is_balancer = 1;                  $is_balancer = 1;
                 $offloadto = &this_host_spares($dom_in_use);                  $offloadto = &this_host_spares($dom_in_use);
             }              }
               unless (defined($cached)) {
                   $domneedscache = $serverhomedom;
               }
         }          }
     } else {      } else {
         if ($perlvar{'lonBalancer'} eq 'yes') {          if ($perlvar{'lonBalancer'} eq 'yes') {
             $is_balancer = 1;              $is_balancer = 1;
             $offloadto = &this_host_spares($dom_in_use);              $offloadto = &this_host_spares($dom_in_use);
         }          }
           unless (defined($cached)) {
               $domneedscache = $serverhomedom;
           }
       }
       if ($domneedscache) {
           &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime);
     }      }
     if ($is_balancer) {      if ($is_balancer) {
         my $lowest_load = 30000;          my $lowest_load = 30000;
Line 1895  sub retrieve_inst_usertypes { Line 1908  sub retrieve_inst_usertypes {
   
 sub is_domainimage {  sub is_domainimage {
     my ($url) = @_;      my ($url) = @_;
     if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+-) {      if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+[^/]-) {
         if (&domain($1) ne '') {          if (&domain($1) ne '') {
             return '1';              return '1';
         }          }
Line 2189  sub get_domain_defaults { Line 2202  sub get_domain_defaults {
                                   'requestcourses','inststatus',                                    'requestcourses','inststatus',
                                   'coursedefaults','usersessions',                                    'coursedefaults','usersessions',
                                   'requestauthor','selfenrollment',                                    'requestauthor','selfenrollment',
                                   'coursecategories'],$domain);                                    'coursecategories','autoenroll'],$domain);
     my @coursetypes = ('official','unofficial','community','textbook');      my @coursetypes = ('official','unofficial','community','textbook','placement');
     if (ref($domconfig{'defaults'}) eq 'HASH') {      if (ref($domconfig{'defaults'}) eq 'HASH') {
         $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};           $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
         $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};          $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
Line 2220  sub get_domain_defaults { Line 2233  sub get_domain_defaults {
         }          }
     }      }
     if (ref($domconfig{'requestcourses'}) eq 'HASH') {      if (ref($domconfig{'requestcourses'}) eq 'HASH') {
         foreach my $item ('official','unofficial','community','textbook') {          foreach my $item ('official','unofficial','community','textbook','placement') {
             $domdefaults{$item} = $domconfig{'requestcourses'}{$item};              $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
         }          }
     }      }
Line 2315  sub get_domain_defaults { Line 2328  sub get_domain_defaults {
             $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};              $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};
         }          }
     }      }
       if (ref($domconfig{'autoenroll'}) eq 'HASH') {
           $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};
       }
     &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);      &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
     return %domdefaults;      return %domdefaults;
 }  }
   
   sub course_portal_url {
       my ($cnum,$cdom) = @_;
       my $chome = &homeserver($cnum,$cdom);
       my $hostname = &hostname($chome);
       my $protocol = $protocol{$chome};
       $protocol = 'http' if ($protocol ne 'https');
       my %domdefaults = &get_domain_defaults($cdom);
       my $firsturl;
       if ($domdefaults{'portal_def'}) {
           $firsturl = $domdefaults{'portal_def'};
       } else {
           $firsturl = $protocol.'://'.$hostname;
       }
       return $firsturl;
   }
   
 # --------------------------------------------------- Assign a key to a student  # --------------------------------------------------- Assign a key to a student
   
 sub assign_access_key {  sub assign_access_key {
Line 4633  my %cachedtimes=(); Line 4665  my %cachedtimes=();
 my $cachedtime='';  my $cachedtime='';
   
 sub load_all_first_access {  sub load_all_first_access {
     my ($uname,$udom)=@_;      my ($uname,$udom,$ignorecache)=@_;
     if (($cachedkey eq $uname.':'.$udom) &&      if (($cachedkey eq $uname.':'.$udom) &&
         (abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) {          (abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) &&
           (!$ignorecache)) {
         return;          return;
     }      }
     $cachedtime=time;      $cachedtime=time;
Line 4644  sub load_all_first_access { Line 4677  sub load_all_first_access {
 }  }
   
 sub get_first_access {  sub get_first_access {
     my ($type,$argsymb,$argmap)=@_;      my ($type,$argsymb,$argmap,$ignorecache)=@_;
     my ($symb,$courseid,$udom,$uname)=&whichuser();      my ($symb,$courseid,$udom,$uname)=&whichuser();
     if ($argsymb) { $symb=$argsymb; }      if ($argsymb) { $symb=$argsymb; }
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
Line 4656  sub get_first_access { Line 4689  sub get_first_access {
     } else {      } else {
  $res=$symb;   $res=$symb;
     }      }
     &load_all_first_access($uname,$udom);      &load_all_first_access($uname,$udom,$ignorecache);
     return $cachedtimes{"$courseid\0$res"};      return $cachedtimes{"$courseid\0$res"};
 }  }
   
Line 6530  sub usertools_access { Line 6563  sub usertools_access {
                       unofficial => 1,                        unofficial => 1,
                       community  => 1,                        community  => 1,
                       textbook   => 1,                        textbook   => 1,
                         placement  => 1,
                  );                   );
     } elsif ($context eq 'requestauthor') {      } elsif ($context eq 'requestauthor') {
         %tools = (          %tools = (
Line 7263  sub allowed { Line 7297  sub allowed {
        my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};         my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
    =~/\Q$rolecode\E/) {     =~/\Q$rolecode\E/) {
    if (($priv ne 'pch') && ($priv ne 'plc')) {      if (($priv ne 'pch') && ($priv ne 'plc') && ($priv ne 'pac')) {
        &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
  'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.   'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
  $env{'request.course.id'});   $env{'request.course.id'});
Line 7273  sub allowed { Line 7307  sub allowed {
   
        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
    =~/\Q$unamedom\E/) {     =~/\Q$unamedom\E/) {
    if (($priv ne 'pch') && ($priv ne 'plc')) {      if (($priv ne 'pch') && ($priv ne 'plc') && ($priv ne 'pac')) {
        &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
  'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.   'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
  $env{'request.course.id'});   $env{'request.course.id'});
Line 7352  sub constructaccess { Line 7386  sub constructaccess {
             $ownerhome = &homeserver($ownername,$ownerdomain);              $ownerhome = &homeserver($ownername,$ownerdomain);
             return ($ownername,$ownerdomain,$ownerhome);              return ($ownername,$ownerdomain,$ownerhome);
         }          }
           if ($env{'request.course.id'}) {
               if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) &&
                   ($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) {
                   if (&allowed('mdc',$env{'request.course.id'})) {
                       $ownerhome = $env{'course.'.$env{'request.course.id'}.'.home'};
                       return ($ownername,$ownerdomain,$ownerhome);
                   }
               }
           }
     }      }
   
 # We don't have any access right now. If we are not possibly going to do anything about this,  # We don't have any access right now. If we are not possibly going to do anything about this,
Line 7504  sub get_commblock_resources { Line 7547  sub get_commblock_resources {
                             }                              }
                         }                          }
                     }                      }
                     if ($interval[0] =~ /^\d+/) {                      if ($interval[0] =~ /^(\d+)/) {
                         my ($timelimit) = split(/_/,$interval[0]);                          my $timelimit = $1; 
                         my $first_access;                          my $first_access;
                         if ($type eq 'resource') {                          if ($type eq 'resource') {
                             $first_access=&get_first_access($interval[1],$item);                              $first_access=&get_first_access($interval[1],$item);
Line 8277  sub auto_crsreq_update { Line 8320  sub auto_crsreq_update {
     return \%crsreqresponse;      return \%crsreqresponse;
 }  }
   
   sub auto_export_grades {
       my ($cdom,$cnum,$inforef,$gradesref) = @_;
       my ($homeserver,%exportresponse);
       if ($cdom =~ /^$match_domain$/) {
           $homeserver = &domain($cdom,'primary');
       }
       unless (($homeserver eq 'no_host') || ($homeserver eq '')) {
           my $info;
           if (ref($inforef) eq 'HASH') {
               $info = &freeze_escape($inforef);
           }
           if (ref($gradesref) eq 'HASH') {
               my $grades = &freeze_escape($gradesref);
               my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'.
                                   $info.':'.$grades,$homeserver);
               unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/) {
                   my @items = split(/&/,$response);
                   foreach my $item (@items) {
                       my ($key,$value) = split('=',$item);
                       $exportresponse{&unescape($key)} = &thaw_unescape($value);
                   }
               }
           }
       }
       return \%exportresponse;
   }
   
 sub check_instcode_cloning {  sub check_instcode_cloning {
     my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_;      my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_;
     unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {      unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {
Line 8498  sub plaintext { Line 8568  sub plaintext {
     my %rolenames = (      my %rolenames = (
                       Course    => 'std',                        Course    => 'std',
                       Community => 'alt1',                        Community => 'alt1',
                         Placement => 'std',
                     );                      );
     if ($cid ne '') {      if ($cid ne '') {
         if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') {          if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') {
Line 9020  sub modifyuser { Line 9091  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,$credits,$instsec)=@_;
     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 9036  sub modifystudent { Line 9107  sub modifystudent {
     $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,$instsec);
     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,$credits) = @_;          $locktype,$cid,$selfenroll,$context,$credits,$instsec) = @_;
     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 9089  sub modify_student_enrollment { Line 9160  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,$credits,$instsec) },
    $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 10148  sub stat_file { Line 10219  sub stat_file {
     return ();      return ();
 }  }
   
   # --------------------------------------------------------- recursedirs
   # Recursive function to traverse either a specific user's Authoring Space
   # or corresponding Published Resource Space, and populate the hash ref:
   # $dirhashref with URLs of all directories, and if $filehashref hash
   # ref arg is provided, the URLs of any files, excluding versioned, .meta,
   # or .rights files in resource space, and .meta, .save, .log, and .bak
   # files in Authoring Space.
   #
   # Inputs:
   #
   # $is_home - true if current server is home server for user's space
   # $context - either: priv, or res respectively for Authoring or Resource Space.
   # $docroot - Document root (i.e., /home/httpd/html
   # $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname
   # $relpath - Current path (relative to top level).
   # $dirhashref - reference to hash to populate with URLs of directories (Required)
   # $filehashref - reference to hash to populate with URLs of files (Optional)
   #
   # Returns: nothing
   #
   # Side Effects: populates $dirhashref, and $filehashref (if provided).
   #
   # Currently used by interface/londocs.pm to create linked select boxes for
   # directory and filename to import a Course "Author" resource into a course, and
   # also to create linked select boxes for Authoring Space and Directory to choose
   # save location for creation of a new "standard" problem from the Course Editor.
   #
   
   sub recursedirs {
       my ($is_home,$context,$docroot,$toppath,$relpath,$dirhashref,$filehashref) = @_;
       return unless (ref($dirhashref) eq 'HASH');
       my $currpath = $docroot.$toppath;
       if ($relpath) {
           $currpath .= "/$relpath";
       }
       my $savefile;
       if (ref($filehashref)) {
           $savefile = 1;
       }
       if ($is_home) {
           if (opendir(my $dirh,$currpath)) {
               foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) {
                   next if ($item eq '');
                   if (-d "$currpath/$item") {
                       my $newpath;
                       if ($relpath) {
                           $newpath = "$relpath/$item";
                       } else {
                           $newpath = $item;
                       }
                       $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
                       &recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref);
                   } elsif ($savefile) {
                       if ($context eq 'priv') {
                           unless ($item =~ /\.(meta|save|log|bak|DS_Store)$/) {
                               $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
                           }
                       } else {
                           unless (($item =~ /\.meta$/) || ($item =~ /\.\d+\.\w+$/) || ($item =~ /\.rights$/)) {
                               $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
                           }
                       }
                   }
               }
               closedir($dirh);
           }
       } else {
           my ($dirlistref,$listerror) =
               &dirlist($toppath.$relpath);
           my @dir_lines;
           my $dirptr=16384;
           if (ref($dirlistref) eq 'ARRAY') {
               foreach my $dir_line (sort
                                 {
                                     my ($afile)=split('&',$a,2);
                                     my ($bfile)=split('&',$b,2);
                                     return (lc($afile) cmp lc($bfile));
                                 } (@{$dirlistref})) {
                   my ($item,$dom,undef,$testdir,undef,undef,undef,undef,$size,undef,$mtime,undef,undef,undef,$obs,undef) =
                       split(/\&/,$dir_line,16);
                   $item =~ s/\s+$//;
                   next if (($item =~ /^\.\.?$/) || ($obs));
                   if ($dirptr&$testdir) {
                       my $newpath;
                       if ($relpath) {
                           $newpath = "$relpath/$item";
                       } else {
                           $relpath = '/';
                           $newpath = $item;
                       }
                       $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
                       &recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref);
                   } elsif ($savefile) {
                       if ($context eq 'priv') {
                           unless ($item =~ /\.(meta|save|log|bak|DS_Store)$/) {
                               $filehashref->{$relpath}{$item} = 1;
                           }
                       } else {
                           unless (($item =~ /\.meta$/) || ($item =~ /\.\d+\.\w+$/)) {
                               $filehashref->{$relpath}{$item} = 1;
                           }
                       }
                   }
               }
           }
       }
       return;
   }
   
 # -------------------------------------------------------- Value of a Condition  # -------------------------------------------------------- Value of a Condition
   
 # gets the value of a specific preevaluated condition  # gets the value of a specific preevaluated condition
Line 10311  sub get_userresdata { Line 10491  sub get_userresdata {
 #  Parameters:  #  Parameters:
 #     $name      - Course/user name.  #     $name      - Course/user name.
 #     $domain    - Name of the domain the user/course is registered on.  #     $domain    - Name of the domain the user/course is registered on.
 #     $type      - Type of thing $name is (must be 'course' or 'user'  #     $type      - Type of thing $name is (must be 'course' or 'user')
 #     $mapp      - decluttered URL of enclosing map    #     $mapp      - decluttered URL of enclosing map  
 #     $recursed  - Ref to scalar -- set to 1, if nested maps have been recursed.  #     $recursed  - Ref to scalar -- set to 1, if nested maps have been recursed.
 #     $recurseup - Ref to array of map URLs, starting with map containing  #     $recurseup - Ref to array of map URLs, starting with map containing
Line 13686  Inputs: Line 13866  Inputs:
   
 =item $credits, number of credits student will earn from this class  =item $credits, number of credits student will earn from this class
   
   =item $instsec, institutional course section code for student
   
 =back  =back
   
   
Line 14154  requestcourses: ability to request cours Line 14336  requestcourses: ability to request cours
 =over  =over
   
 =item  =item
 official, unofficial, community, textbook  official, unofficial, community, textbook, placement
   
 =back  =back
   
Line 14176  for course's uploaded content. Line 14358  for course's uploaded content.
   
 =item  =item
 canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota,   canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, 
 communityquota, textbookquota  communityquota, textbookquota, placementquota
   
 =back  =back
   
Removed from v.1.1303  
changed lines
  Added in v.1.1314

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