[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.1295 and 1.1309

version 1.1295, 2015/10/26 16:03:42 version 1.1309, 2016/05/30 03:16:33
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 1551  sub homeserver { Line 1564  sub homeserver {
     return 'no_host';      return 'no_host';
 }  }
   
 # ------------------------------------- Find the usernames behind a list of IDs  # ----- Find the usernames behind a list of student/employee IDs or clicker IDs
   
 sub idget {  sub idget {
     my ($udom,@ids)=@_;      my ($udom,$idsref,$namespace)=@_;
     my %returnhash=();      my %returnhash=();
       my @ids=(); 
       if (ref($idsref) eq 'ARRAY') {
           @ids = @{$idsref};
       } else {
           return %returnhash; 
       }
       if ($namespace eq '') {
           $namespace = 'ids';
       }
           
     my %servers = &get_servers($udom,'library');      my %servers = &get_servers($udom,'library');
     foreach my $tryserver (keys(%servers)) {      foreach my $tryserver (keys(%servers)) {
  my $idlist=join('&',@ids);   my $idlist=join('&', map { &escape($_); } @ids);
  $idlist=~tr/A-Z/a-z/;    if ($namespace eq 'ids') {
  my $reply=&reply("idget:$udom:".$idlist,$tryserver);      $idlist=~tr/A-Z/a-z/;
    }
    my $reply;
    if ($namespace eq 'ids') {
       $reply=&reply("idget:$udom:".$idlist,$tryserver);
    } else {
       $reply=&reply("getdom:$udom:$namespace:$idlist",$tryserver);
    }
  my @answer=();   my @answer=();
  if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {   if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
     @answer=split(/\&/,$reply);      @answer=split(/\&/,$reply);
Line 1569  sub idget { Line 1598  sub idget {
  my $i;   my $i;
  for ($i=0;$i<=$#ids;$i++) {   for ($i=0;$i<=$#ids;$i++) {
     if ($answer[$i]) {      if ($answer[$i]) {
  $returnhash{$ids[$i]}=$answer[$i];   $returnhash{$ids[$i]}=&unescape($answer[$i]);
     }       }
  }   }
     }       }
     return %returnhash;      return %returnhash;
 }  }
   
Line 1587  sub idrget { Line 1616  sub idrget {
     return %returnhash;      return %returnhash;
 }  }
   
 # ------------------------------- Store away a list of names and associated IDs  # Store away a list of names and associated student/employee IDs or clicker IDs
   
 sub idput {  sub idput {
     my ($udom,%ids)=@_;      my ($udom,$idsref,$uhom,$namespace)=@_;
     my %servers=();      my %servers=();
       my %ids=();
       my %byid = ();
       if (ref($idsref) eq 'HASH') {
           %ids=%{$idsref};
       }
       if ($namespace eq '') {
           $namespace = 'ids'; 
       }
     foreach my $uname (keys(%ids)) {      foreach my $uname (keys(%ids)) {
  &cput('environment',{'id'=>$ids{$uname}},$udom,$uname);   &cput('environment',{'id'=>$ids{$uname}},$udom,$uname);
         my $uhom=&homeserver($uname,$udom);          if ($uhom eq '') {
               $uhom=&homeserver($uname,$udom);
           }
         if ($uhom ne 'no_host') {          if ($uhom ne 'no_host') {
             my $id=&escape($ids{$uname});  
             $id=~tr/A-Z/a-z/;  
             my $esc_unam=&escape($uname);              my $esc_unam=&escape($uname);
     if ($servers{$uhom}) {              if ($namespace eq 'ids') {
  $servers{$uhom}.='&'.$id.'='.$esc_unam;                  my $id=&escape($ids{$uname});
                   $id=~tr/A-Z/a-z/;
                   my $esc_unam=&escape($uname);
                   $servers{$uhom}.=$id.'='.$esc_unam.'&';
             } else {              } else {
                 $servers{$uhom}=$id.'='.$esc_unam;                  my @currids = split(/,/,$ids{$uname});
                   foreach my $id (@currids) {
                       $byid{$uhom}{$id} .= $uname.',';
                   }
               }
           }
       }
       if ($namespace eq 'clickers') {
           foreach my $server (keys(%byid)) {
               if (ref($byid{$server}) eq 'HASH') {
                   foreach my $id (keys(%{$byid{$server}})) {
                       $byid{$server} =~ s/,$//;
                       $servers{$uhom}.=&escape($id).'='.&escape($byid{$server}).'&'; 
                   }
             }              }
         }          }
     }      }
     foreach my $server (keys(%servers)) {      foreach my $server (keys(%servers)) {
         &critical('idput:'.$udom.':'.$servers{$server},$server);          $servers{$server} =~ s/\&$//;
           if ($namespace eq 'ids') {     
               &critical('idput:'.$udom.':'.$servers{$server},$server);
           } else {
               &critical('updateclickers:'.$udom.':add:'.$servers{$server},$server);
           }
     }      }
 }  }
   
 # ---------------------------------------- Delete unwanted IDs from ids.db file   # ------------- Delete unwanted student/employee IDs or clicker IDs from domain
   
 sub iddel {  sub iddel {
     my ($udom,$idshashref,$uhome)=@_;      my ($udom,$idshashref,$uhome,$namespace)=@_;
     my %result=();      my %result=();
     unless (ref($idshashref) eq 'HASH') {      my %ids=();
       my %byid = ();
       if (ref($idshashref) eq 'HASH') {
           %ids=%{$idshashref};
       } else {
         return %result;          return %result;
     }      }
       if ($namespace eq '') {
           $namespace = 'ids';
       }
     my %servers=();      my %servers=();
     while (my ($id,$uname) = each(%{$idshashref})) {      while (my ($id,$unamestr) = each(%ids)) {
         my $uhom;          if ($namespace eq 'ids') {
         if ($uhome) {              my $uhom = $uhome;
             $uhom = $uhome;              if ($uhom eq '') { 
         } else {                  $uhom=&homeserver($unamestr,$udom);
             $uhom=&homeserver($uname,$udom);              }
         }              if ($uhom ne 'no_host') {
         if ($uhom ne 'no_host') {  
             if ($servers{$uhom}) {  
                 $servers{$uhom}.='&'.&escape($id);                  $servers{$uhom}.='&'.&escape($id);
             } else {              }
                 $servers{$uhom}=&escape($id);           } else {
               my @curritems = split(/,/,$ids{$id});
               foreach my $uname (@curritems) {
                   my $uhom = $uhome;
                   if ($uhom eq '') {
                       $uhom=&homeserver($uname,$udom);
                   }
                   if ($uhom ne 'no_host') { 
                       $byid{$uhom}{$id} .= $uname.',';
                   }
               }
           }
       }
       if ($namespace eq 'clickers') {
           foreach my $server (keys(%byid)) {
               if (ref($byid{$server}) eq 'HASH') {
                   foreach my $id (keys(%{$byid{$server}})) {
                       $byid{$server}{$id} =~ s/,$//;
                       $servers{$server}.=&escape($id).'='.&escape($byid{$server}{$id}).'&';
                   }
             }              }
         }          }
     }      }
     foreach my $server (keys(%servers)) {      foreach my $server (keys(%servers)) {
         $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome);          $servers{$server} =~ s/\&$//;
           if ($namespace eq 'ids') {
               $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome);
           } elsif ($namespace eq 'clickers') {
               $result{$server} = &critical('updateclickers:'.$udom.':del:'.$servers{$server},$server);
           }
     }      }
     return %result;      return %result;
 }  }
   
   # ----- Update clicker ID-to-username look-ups in clickers.db on library server 
   
   sub updateclickers {
       my ($udom,$action,$idshashref,$uhome,$critical) = @_;
       my %clickers;
       if (ref($idshashref) eq 'HASH') {
           %clickers=%{$idshashref};
       } else {
           return;
       }
       my $items='';
       foreach my $item (keys(%clickers)) {
           $items.=&escape($item).'='.&escape($clickers{$item}).'&';
       }
       $items=~s/\&$//;
       my $request = "updateclickers:$udom:$action:$items";
       if ($critical) {
           return &critical($request,$uhome);
       } else {
           return &reply($request,$uhome);
       }
   }
   
 # ------------------------------dump from db file owned by domainconfig user  # ------------------------------dump from db file owned by domainconfig user
 sub dump_dom {  sub dump_dom {
     my ($namespace, $udom, $regexp) = @_;      my ($namespace, $udom, $regexp) = @_;
Line 1798  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 2093  sub get_domain_defaults { Line 2203  sub get_domain_defaults {
                                   'coursedefaults','usersessions',                                    'coursedefaults','usersessions',
                                   'requestauthor','selfenrollment',                                    'requestauthor','selfenrollment',
                                   'coursecategories'],$domain);                                    'coursecategories'],$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 2123  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 2980  sub can_edit_resource { Line 3090  sub can_edit_resource {
                         $forceedit = 1;                          $forceedit = 1;
                     }                      }
                     $cfile = $resurl;                      $cfile = $resurl;
                   } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) {
                       $incourse = 1;
                       if ($env{'form.forceedit'}) {
                           $forceview = 1;
                       } else {
                           $forceedit = 1;
                       }
                       $cfile = $resurl;
                 } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {                  } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
                     $incourse = 1;                      $incourse = 1;
                     if ($env{'form.forceedit'}) {                      if ($env{'form.forceedit'}) {
Line 3004  sub can_edit_resource { Line 3122  sub can_edit_resource {
                         $forceedit = 1;                          $forceedit = 1;
                     }                      }
                     $cfile = $resurl;                      $cfile = $resurl;
               } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) && ($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'})) {              } elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) {
                 $incourse = 1;                  $incourse = 1;
                 $forceview = 1;                  $forceview = 1;
Line 3013  sub can_edit_resource { Line 3139  sub can_edit_resource {
                     $cfile = &clutter($res);                      $cfile = &clutter($res);
                 } else {                  } else {
                     $cfile = $env{'form.suppurl'};                      $cfile = $env{'form.suppurl'};
                     $cfile =~ s{^http://}{};                      my $escfile = &unescape($cfile);
                     $cfile = '/adm/wrapper/ext/'.$cfile;                      if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/exttools?$}) {
                           $cfile = '/adm/wrapper'.$escfile;
                       } else {
                           $escfile =~ s{^http://}{};
                           $cfile = &escape("/adm/wrapper/ext/$escfile");
                       }
                 }                  }
             } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {              } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
                 if ($env{'form.forceedit'}) {                  if ($env{'form.forceedit'}) {
Line 4515  my %cachedtimes=(); Line 4646  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 4526  sub load_all_first_access { Line 4658  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 4538  sub get_first_access { Line 4670  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 6412  sub usertools_access { Line 6544  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 7145  sub allowed { Line 7278  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 7155  sub allowed { Line 7288  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 7213  sub constructaccess { Line 7346  sub constructaccess {
     my ($ownername,$ownerdomain,$ownerhome);      my ($ownername,$ownerdomain,$ownerhome);
   
     ($ownerdomain,$ownername) =      ($ownerdomain,$ownername) =
         ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)/});          ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)(?:/daxepage|/daxeopen)?/priv/($match_domain)/($match_username)/});
   
 # The URL does not really point to any authorspace, forget it  # The URL does not really point to any authorspace, forget it
     unless (($ownername) && ($ownerdomain)) { return ''; }      unless (($ownername) && ($ownerdomain)) { return ''; }
Line 7386  sub get_commblock_resources { Line 7519  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 8159  sub auto_crsreq_update { Line 8292  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 8380  sub plaintext { Line 8540  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 8792  sub modifyuser { Line 8953  sub modifyuser {
                   'current user id "'.$uidhash{$uname}.'".';                    'current user id "'.$uidhash{$uname}.'".';
           }            }
        } else {         } else {
   &idput($udom,($uname => $uid));    &idput($udom,{$uname => $uid},$uhome,'ids');
        }         }
     }      }
 # -------------------------------------------------------------- Add names, etc  # -------------------------------------------------------------- Add names, etc
Line 10194  sub get_userresdata { Line 10355  sub get_userresdata {
 #     $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  
   #     $recursed  - Ref to scalar -- set to 1, if nested maps have been recursed.
   #     $recurseup - Ref to array of map URLs, starting with map containing
   #                  $mapp up through hierarchy of nested maps to top level map.  
   #     $courseid  - CourseID (first part of param identifier).
   #     $modifier  - Middle part of param identifier.
   #     $what      - Last part of param identifier.
 #     @which     - Array of names of resources desired.  #     @which     - Array of names of resources desired.
 #  Returns:  #  Returns:
 #     The value of the first reasource in @which that is found in the  #     The value of the first reasource in @which that is found in the
Line 10203  sub get_userresdata { Line 10371  sub get_userresdata {
 #     'user', an undefined  reference is returned.  #     'user', an undefined  reference is returned.
 #     If none of the resources are found, an undef is returned  #     If none of the resources are found, an undef is returned
 sub resdata {  sub resdata {
     my ($name,$domain,$type,@which)=@_;      my ($name,$domain,$type,$mapp,$recursed,$recurseup,$courseid,
           $modifier,$what,@which)=@_;
     my $result;      my $result;
     if ($type eq 'course') {      if ($type eq 'course') {
  $result=&get_courseresdata($name,$domain);   $result=&get_courseresdata($name,$domain);
Line 10212  sub resdata { Line 10381  sub resdata {
     }      }
     if (!ref($result)) { return $result; }          if (!ref($result)) { return $result; }    
     foreach my $item (@which) {      foreach my $item (@which) {
  if (defined($result->{$item->[0]})) {          if ($item->[1] eq 'course') {
               if ((ref($recurseup) eq 'ARRAY') && (ref($recursed) eq 'SCALAR')) {
                   unless ($$recursed) {
                       @{$recurseup} = &get_map_hierarchy($mapp,$courseid);
                       $$recursed = 1;
                   }
                   foreach my $item (@${recurseup}) {
                       my $norecursechk=$courseid.$modifier.$item.'___(all).'.$what;
                       last if (defined($result->{$norecursechk}));
                       my $recursechk=$courseid.$modifier.$item.'___(rec).'.$what;
                       if (defined($result->{$recursechk})) { return [$result->{$recursechk},'map']; }
                   }
               }
           }
           if (defined($result->{$item->[0]})) {
     return [$result->{$item->[0]},$item->[1]];      return [$result->{$item->[0]},$item->[1]];
  }   }
     }      }
     return undef;      return undef;
 }  }
   
   sub get_domain_ltitools {
       my ($cdom) = @_;
       my %ltitools;
       my ($result,$cached)=&is_cached_new('ltitools',$cdom);
       if (defined($cached)) {
           if (ref($result) eq 'HASH') {
               %ltitools = %{$result};
           }
       } else {
           my %domconfig = &get_dom('configuration',['ltitools'],$cdom);
           if (ref($domconfig{'ltitools'}) eq 'HASH') {
               %ltitools = %{$domconfig{'ltitools'}};
           }
           my $cachetime = 24*60*60;
           &do_cache_new('ltitools',$cdom,\%ltitools,$cachetime);
       }
       return %ltitools;
   }
   
 sub get_numsuppfiles {  sub get_numsuppfiles {
     my ($cnum,$cdom,$ignorecache)=@_;      my ($cnum,$cdom,$ignorecache)=@_;
     my $hashid=$cnum.':'.$cdom;      my $hashid=$cnum.':'.$cdom;
Line 10243  sub get_numsuppfiles { Line 10445  sub get_numsuppfiles {
 # EXT resource caching routines  # EXT resource caching routines
 #  #
   
   {
   # Cache (5 seconds) of map hierarchy for speedup of navmaps display
   #
   # The course for which we cache
   my $cachedmapkey='';
   # The cached recursive maps for this course
   my %cachedmaps=();
   # When this was last done
   my $cachedmaptime='';
   
 sub clear_EXT_cache_status {  sub clear_EXT_cache_status {
     &delenv('cache.EXT.');      &delenv('cache.EXT.');
 }  }
Line 10420  sub EXT { Line 10632  sub EXT {
             }              }
         }          }
   
  my ($section, $group, @groups);   my ($section, $group, @groups, @recurseup, $recursed);
  my ($courselevelm,$courselevel);   my ($courselevelm,$courseleveli,$courselevel,$mapp);
         if (($courseid eq '') && ($cid)) {          if (($courseid eq '') && ($cid)) {
             $courseid = $cid;              $courseid = $cid;
         }          }
Line 10432  sub EXT { Line 10644  sub EXT {
   
 # ----------------------------------------------------- Cascading lookup scheme  # ----------------------------------------------------- Cascading lookup scheme
     my $symbp=$symbparm;      my $symbp=$symbparm;
     my $mapp=&deversion((&decode_symb($symbp))[0]);      $mapp=&deversion((&decode_symb($symbp))[0]);
   
     my $symbparm=$symbp.'.'.$spacequalifierrest;      my $symbparm=$symbp.'.'.$spacequalifierrest;
               my $recurseparm=$mapp.'___(rec).'.$spacequalifierrest;
     my $mapparm=$mapp.'___(all).'.$spacequalifierrest;      my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
   
     if (($env{'user.name'} eq $uname) &&      if (($env{'user.name'} eq $uname) &&
  ($env{'user.domain'} eq $udom)) {   ($env{'user.domain'} eq $udom)) {
  $section=$env{'request.course.sec'};   $section=$env{'request.course.sec'};
Line 10453  sub EXT { Line 10664  sub EXT {
   
     my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;      my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
     my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;      my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
               my $secleveli=$courseid.'.['.$section.'].'.$recurseparm;
     my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;      my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
   
     $courselevel=$courseid.'.'.$spacequalifierrest;      $courselevel=$courseid.'.'.$spacequalifierrest;
     my $courselevelr=$courseid.'.'.$symbparm;      my $courselevelr=$courseid.'.'.$symbparm;
               $courseleveli=$courseid.'.'.$recurseparm;
     $courselevelm=$courseid.'.'.$mapparm;      $courselevelm=$courseid.'.'.$mapparm;
   
 # ----------------------------------------------------------- first, check user  # ----------------------------------------------------------- first, check user
   
     my $userreply=&resdata($uname,$udom,'user',      my $userreply=&resdata($uname,$udom,'user',$mapp,\$recursed,
                                      \@recurseup,$courseid,'.',$spacequalifierrest, 
        ([$courselevelr,'resource'],         ([$courselevelr,'resource'],
  [$courselevelm,'map'     ],   [$courselevelm,'map'     ],
                                           [$courseleveli,'map'     ],
  [$courselevel, 'course'  ]));   [$courselevel, 'course'  ]));
     if (defined($userreply)) { return &get_reply($userreply); }      if (defined($userreply)) { return &get_reply($userreply); }
   
Line 10471  sub EXT { Line 10686  sub EXT {
             my $coursereply;              my $coursereply;
             if (@groups > 0) {              if (@groups > 0) {
                 $coursereply = &check_group_parms($courseid,\@groups,$symbparm,                  $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
                                        $mapparm,$spacequalifierrest);                                         $recurseparm,$mapparm,$spacequalifierrest,
                 if (defined($coursereply)) { return &get_reply($coursereply); }                                         $mapp,\$recursed,\@recurseup);
                   if (defined($coursereply)) { return &get_reply($coursereply); } 
             }              }
   
     $coursereply=&resdata($env{'course.'.$courseid.'.num'},      $coursereply=&resdata($env{'course.'.$courseid.'.num'},
   $env{'course.'.$courseid.'.domain'},    $env{'course.'.$courseid.'.domain'},
   'course',    'course',$mapp,\$recursed,\@recurseup,
                                     $courseid,'.['.$section.'].',$spacequalifierrest,
   ([$seclevelr,   'resource'],    ([$seclevelr,   'resource'],
    [$seclevelm,   'map'     ],     [$seclevelm,   'map'     ],
                                      [$secleveli,   'map'     ],
    [$seclevel,    'course'  ],     [$seclevel,    'course'  ],
    [$courselevelr,'resource']));     [$courselevelr,'resource']));
     if (defined($coursereply)) { return &get_reply($coursereply); }      if (defined($coursereply)) { return &get_reply($coursereply); }
Line 10496  sub EXT { Line 10714  sub EXT {
     if ($thisparm) { return &get_reply([$thisparm,'resource']); }      if ($thisparm) { return &get_reply([$thisparm,'resource']); }
  }   }
 # ------------------------------------------ fourth, look in resource metadata  # ------------------------------------------ fourth, look in resource metadata
    
  $spacequalifierrest=~s/\./\_/;          my $what = $spacequalifierrest;
    $what=~s/\./\_/;
  my $filename;   my $filename;
  if (!$symbparm) { $symbparm=&symbread(); }   if (!$symbparm) { $symbparm=&symbread(); }
  if ($symbparm) {   if ($symbparm) {
Line 10505  sub EXT { Line 10724  sub EXT {
  } else {   } else {
     $filename=$env{'request.filename'};      $filename=$env{'request.filename'};
  }   }
  my $metadata=&metadata($filename,$spacequalifierrest);   my $metadata=&metadata($filename,$what);
  if (defined($metadata)) { return &get_reply([$metadata,'resource']); }   if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
  $metadata=&metadata($filename,'parameter_'.$spacequalifierrest);   $metadata=&metadata($filename,'parameter_'.$what);
  if (defined($metadata)) { return &get_reply([$metadata,'resource']); }   if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
   
 # ---------------------------------------------- fourth, look in rest of course  # ----------------------------------------------- fifth, look in rest of course
  if ($symbparm && defined($courseid) &&    if ($symbparm && defined($courseid) && 
     $courseid eq $env{'request.course.id'}) {      $courseid eq $env{'request.course.id'}) {
     my $coursereply=&resdata($env{'course.'.$courseid.'.num'},      my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
      $env{'course.'.$courseid.'.domain'},       $env{'course.'.$courseid.'.domain'},
      'course',       'course',$mapp,\$recursed,\@recurseup,
                                        $courseid,'.',$spacequalifierrest,
      ([$courselevelm,'map'   ],       ([$courselevelm,'map'   ],
                                         [$courseleveli,'map'   ],
       [$courselevel, 'course']));        [$courselevel, 'course']));
     if (defined($coursereply)) { return &get_reply($coursereply); }      if (defined($coursereply)) { return &get_reply($coursereply); }
  }   }
Line 10573  sub get_reply { Line 10794  sub get_reply {
 }  }
   
 sub check_group_parms {  sub check_group_parms {
     my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;      my ($courseid,$groups,$symbparm,$recurseparm,$mapparm,$what,$mapp,
     my @groupitems = ();          $recursed,$recurseupref) = @_;
     my $resultitem;      my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$recurseparm,'map'],
     my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$what,'course']);                    [$what,'course']);
       my $coursereply;
     foreach my $group (@{$groups}) {      foreach my $group (@{$groups}) {
           my @groupitems = ();
         foreach my $level (@levels) {          foreach my $level (@levels) {
              my $item = $courseid.'.['.$group.'].'.$level->[0];               my $item = $courseid.'.['.$group.'].'.$level->[0];
              push(@groupitems,[$item,$level->[1]]);               push(@groupitems,[$item,$level->[1]]);
         }          }
           my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
                                      $env{'course.'.$courseid.'.domain'},
                                      'course',$mapp,$recursed,$recurseupref,
                                      $courseid,'.['.$group.'].',$what,
                                      @groupitems);
           last if (defined($coursereply));
     }      }
     my $coursereply = &resdata($env{'course.'.$courseid.'.num'},  
                             $env{'course.'.$courseid.'.domain'},  
                                      'course',@groupitems);  
     return $coursereply;      return $coursereply;
 }  }
   
   sub get_map_hierarchy {
       my ($mapname,$courseid) = @_;
       my @recurseup = ();
       if ($mapname) {
           if (($cachedmapkey eq $courseid) &&
               (abs($cachedmaptime-time)<5)) {
               if (ref($cachedmaps{$mapname}) eq 'ARRAY') {
                   return @{$cachedmaps{$mapname}};
               }
           }
           my $navmap = Apache::lonnavmaps::navmap->new();
           if (ref($navmap)) {
               @recurseup = $navmap->recurseup_maps($mapname);
               undef($navmap);
               $cachedmaps{$mapname} = \@recurseup;
               $cachedmaptime=time;
               $cachedmapkey=$courseid;
           }
       }
       return @recurseup;
   }
   
   }
   
 sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().  sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
     my ($courseid,@groups) = @_;      my ($courseid,@groups) = @_;
     @groups = sort(@groups);      @groups = sort(@groups);
Line 10673  sub metadata { Line 10923  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{/(smppg|bulletinboard|exttools?)$})) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
  return undef;   return undef;
     }      }
Line 12206  sub clutter { Line 12456  sub clutter {
 # &logthis("Got a blank emb style");  # &logthis("Got a blank emb style");
     }      }
  }   }
       } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/exttools?$}) {
           $thisfn='/adm/wrapper'.$thisfn;
     }      }
     return $thisfn;      return $thisfn;
 }  }
Line 12875  BEGIN { Line 13127  BEGIN {
                 my $name = $token->[2]{'name'};                  my $name = $token->[2]{'name'};
                 my $value = $token->[2]{'value'};                  my $value = $token->[2]{'value'};
                 my $valuematch = $token->[2]{'valuematch'};                  my $valuematch = $token->[2]{'valuematch'};
                 if ($item ne '' && $name ne '' && ($value ne '' || $valuematch ne '')) {                  my $namematch = $token->[2]{'namematch'};
                   if ($item eq 'parameter') {
                       if (($namematch ne '') || (($name ne '') && ($value ne '' || $valuematch ne ''))) {
                           my $release = $parser->get_text();
                           $release =~ s/(^\s*|\s*$ )//gx;
                           $needsrelease{$item.':'.$name.':'.$value.':'.$valuematch.':'.$namematch} = $release;
                       }
                   } elsif ($item ne '' && $name ne '') {
                     my $release = $parser->get_text();                      my $release = $parser->get_text();
                     $release =~ s/(^\s*|\s*$ )//gx;                      $release =~ s/(^\s*|\s*$ )//gx;
                     $needsrelease{$item.':'.$name.':'.$value.':'.$valuematch} = $release;                      $needsrelease{$item.':'.$name.':'.$value} = $release;
                 }                  }
             }              }
         }          }
Line 13148  the answer, and also caches if there is Line 13407  the answer, and also caches if there is
   
 =item *  =item *
 X<idget()>  X<idget()>
 B<idget($udom,@ids)>: find the usernames behind a list of IDs  B<idget($udom,$idsref,$namespace)>: find the usernames behind either 
 (IDs are a unique resource in a domain, there must be only 1 ID per  a list of student/employee IDs or clicker IDs
 username, and only 1 username per ID in a specific domain) (returns  (student/employee IDs are a unique resource in a domain, there must be 
 hash: id=>name,id=>name)  only 1 ID per username, and only 1 username per ID in a specific domain).
   clickerIDs are not necessarily unique, as students might share clickers.
   (returns hash: id=>name,id=>name)
   
 =item *  =item *
 X<idrget()>  X<idrget()>
Line 13160  usernames (returns hash: name=>id,name=> Line 13421  usernames (returns hash: name=>id,name=>
   
 =item *  =item *
 X<idput()>  X<idput()>
 B<idput($udom,%ids)>: store away a list of names and associated IDs  B<idput($udom,$idsref,$uhome,$namespace)>: store away a list of 
   names and associated student/employee IDs or clicker IDs.
   
   =item *
   X<iddel()>
   B<iddel($udom,$idshashref,$uhome,$namespace)>: delete unwanted 
   student/employee ID or clicker ID username look-ups from domain.
   The homeserver ($uhome) and namespace ($namespace) are optional.
   If no $uhome is provided, it will be determined usig &homeserver()
   for each user.  If no $namespace is provided, the default is ids.
   
   =item *
   X<updateclickers()>
   B<updateclickers($udom,$action,$idshashref,$uhome,$critical)>: update 
   clicker ID-to-username look-ups in clickers.db on library server.
   Permitted actions are add or del (i.e., add or delete). The 
   clickers.db contains clickerID as keys (escaped), and each corresponding
   value is an escaped comma-separated list of usernames (for whom the
   library server is the homeserver), who registered that particular ID.
   If $critical is true, the update will be sent via &critical, otherwise
   &reply() will be used.
   
 =item *  =item *
 X<rolesinit()>  X<rolesinit()>
Line 13916  requestcourses: ability to request cours Line 14197  requestcourses: ability to request cours
 =over  =over
   
 =item  =item
 official, unofficial, community, textbook  official, unofficial, community, textbook, placement
   
 =back  =back
   
Line 13938  for course's uploaded content. Line 14219  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.1295  
changed lines
  Added in v.1.1309

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