[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.918 and 1.935

version 1.918, 2007/10/03 19:57:26 version 1.935, 2007/12/21 04:34:50
Line 513  sub get_env_multiple { Line 513  sub get_env_multiple {
 }  }
   
 # ------------------------------------------ Find out current server userload  # ------------------------------------------ Find out current server userload
 # there is a copy in lond  
 sub userload {  sub userload {
     my $numusers=0;      my $numusers=0;
     {      {
Line 521  sub userload { Line 520  sub userload {
  my $filename;   my $filename;
  my $curtime=time;   my $curtime=time;
  while ($filename=readdir(LONIDS)) {   while ($filename=readdir(LONIDS)) {
     if ($filename eq '.' || $filename eq '..') {next;}      next if ($filename eq '.' || $filename eq '..');
       next if ($filename =~ /publicuser_\d+\.id/);
     my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];      my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
     if ($curtime-$mtime < 1800) { $numusers++; }      if ($curtime-$mtime < 1800) { $numusers++; }
  }   }
Line 1047  sub get_instuser { Line 1047  sub get_instuser {
 }  }
   
 sub inst_rulecheck {  sub inst_rulecheck {
     my ($udom,$uname,$rules) = @_;      my ($udom,$uname,$id,$item,$rules) = @_;
     my %returnhash;      my %returnhash;
     if ($udom ne '') {      if ($udom ne '') {
         if (ref($rules) eq 'ARRAY') {          if (ref($rules) eq 'ARRAY') {
Line 1055  sub inst_rulecheck { Line 1055  sub inst_rulecheck {
             my $rulestr = join(':',@{$rules});              my $rulestr = join(':',@{$rules});
             my $homeserver=&domain($udom,'primary');              my $homeserver=&domain($udom,'primary');
             if (($homeserver ne '') && ($homeserver ne 'no_host')) {              if (($homeserver ne '') && ($homeserver ne 'no_host')) {
                 my $response=&unescape(&reply('instrulecheck:'.&escape($udom).':'.                  my $response;
                                               &escape($uname).':'.$rulestr,                  if ($item eq 'username') {                
                       $response=&unescape(&reply('instrulecheck:'.&escape($udom).
                                                 ':'.&escape($uname).':'.$rulestr,
                                               $homeserver));                                                $homeserver));
                   } elsif ($item eq 'id') {
                       $response=&unescape(&reply('instidrulecheck:'.&escape($udom).
                                                 ':'.&escape($id).':'.$rulestr,
                                                 $homeserver));
                   }
                 if ($response ne 'refused') {                  if ($response ne 'refused') {
                     my @pairs=split(/\&/,$response);                      my @pairs=split(/\&/,$response);
                     foreach my $item (@pairs) {                      foreach my $item (@pairs) {
Line 1074  sub inst_rulecheck { Line 1081  sub inst_rulecheck {
 }  }
   
 sub inst_userrules {  sub inst_userrules {
     my ($udom) = @_;      my ($udom,$check) = @_;
     my (%ruleshash,@ruleorder);      my (%ruleshash,@ruleorder);
     if ($udom ne '') {      if ($udom ne '') {
         my $homeserver=&domain($udom,'primary');          my $homeserver=&domain($udom,'primary');
         if (($homeserver ne '') && ($homeserver ne 'no_host')) {          if (($homeserver ne '') && ($homeserver ne 'no_host')) {
             my $response=&reply('instuserrules:'.&escape($udom),              my $response;
               if ($check eq 'id') {
                   $response=&reply('instidrules:'.&escape($udom),
                                  $homeserver);                                   $homeserver);
               } else {
                   $response=&reply('instuserrules:'.&escape($udom),
                                    $homeserver);
               }
             if (($response ne 'refused') && ($response ne 'error') &&               if (($response ne 'refused') && ($response ne 'error') && 
                   ($response ne 'unknown_cmd') && 
                 ($response ne 'no_such_host')) {                  ($response ne 'no_such_host')) {
                 my ($hashitems,$orderitems) = split(/:/,$response);                  my ($hashitems,$orderitems) = split(/:/,$response);
                 my @pairs=split(/\&/,$hashitems);                  my @pairs=split(/\&/,$hashitems);
Line 1383  sub do_cache_new { Line 1397  sub do_cache_new {
  $memcache->disconnect_all();   $memcache->disconnect_all();
     }      }
     # need to make a copy of $value      # need to make a copy of $value
     #&make_room($id,$value,$debug);      &make_room($id,$value,$debug);
     return $value;      return $value;
 }  }
   
 sub make_room {  sub make_room {
     my ($id,$value,$debug)=@_;      my ($id,$value,$debug)=@_;
     $remembered{$id}=$value;  
       $remembered{$id}= (ref($value)) ? &Storable::dclone($value)
                                       : $value;
     if ($to_remember<0) { return; }      if ($to_remember<0) { return; }
     $accessed{$id}=[&gettimeofday()];      $accessed{$id}=[&gettimeofday()];
     if (scalar(keys(%remembered)) <= $to_remember) { return; }      if (scalar(keys(%remembered)) <= $to_remember) { return; }
Line 1619  sub ssi_body { Line 1635  sub ssi_body {
                                      &ssi($filelink,%form));                                       &ssi($filelink,%form));
     $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;      $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
     $output=~s/^.*?\<body[^\>]*\>//si;      $output=~s/^.*?\<body[^\>]*\>//si;
     $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;      $output=~s/\<\/body\s*\>.*?$//si;
     return $output;      return $output;
 }  }
   
Line 2170  sub flushcourselogs { Line 2186  sub flushcourselogs {
 # times and course titles for all courseids  # times and course titles for all courseids
 #  #
     my %courseidbuffer=();      my %courseidbuffer=();
     foreach my $crsid (keys %courselogs) {      foreach my $crsid (keys(%courselogs)) {
         if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.          if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
           &escape($courselogs{$crsid}),            &escape($courselogs{$crsid}),
           $coursehombuf{$crsid}) eq 'ok') {            $coursehombuf{$crsid}) eq 'ok') {
Line 2183  sub flushcourselogs { Line 2199  sub flushcourselogs {
                delete $courselogs{$crsid};                 delete $courselogs{$crsid};
             }              }
         }          }
         $courseidbuffer{$coursehombuf{$crsid}}{$crsid} = (          $courseidbuffer{$coursehombuf{$crsid}}{$crsid} = {
             'description' => &escape($coursedescrbuf{$crsid}),              'description' => &escape($coursedescrbuf{$crsid}),
             'instcode'    => &escape($courseinstcodebuf{$crsid}),              'inst_code'    => &escape($courseinstcodebuf{$crsid}),
             'type'        => &escape($coursetypebuf{$crsid}),              'type'        => &escape($coursetypebuf{$crsid}),
             'owner'       => &escape($courseownerbuf{$crsid}),              'owner'       => &escape($courseownerbuf{$crsid}),
         );          };
     }      }
 #  #
 # Write course id database (reverse lookup) to homeserver of courses   # Write course id database (reverse lookup) to homeserver of courses 
Line 2196  sub flushcourselogs { Line 2212  sub flushcourselogs {
 #  #
     foreach my $crs_home (keys(%courseidbuffer)) {      foreach my $crs_home (keys(%courseidbuffer)) {
         my $response = &courseidput(&host_domain($crs_home),          my $response = &courseidput(&host_domain($crs_home),
                                     $courseidbuffer{$crs_home},$crs_home);                                      $courseidbuffer{$crs_home},
                                       $crs_home,'timeonly');
     }      }
 #  #
 # File accesses  # File accesses
Line 2410  sub get_course_adv_roles { Line 2427  sub get_course_adv_roles {
 }  }
   
 sub get_my_roles {  sub get_my_roles {
     my ($uname,$udom,$context,$types,$roles,$roledoms)=@_;      my ($uname,$udom,$context,$types,$roles,$roledoms,$withsec)=@_;
     unless (defined($uname)) { $uname=$env{'user.name'}; }      unless (defined($uname)) { $uname=$env{'user.name'}; }
     unless (defined($udom)) { $udom=$env{'user.domain'}; }      unless (defined($udom)) { $udom=$env{'user.domain'}; }
     my %dumphash;      my %dumphash;
Line 2460  sub get_my_roles { Line 2477  sub get_my_roles {
         }          }
         if (ref($roles) eq 'ARRAY') {          if (ref($roles) eq 'ARRAY') {
             if (!grep(/^\Q$role\E$/,@{$roles})) {              if (!grep(/^\Q$role\E$/,@{$roles})) {
                 next;                  if ($role =~ /^cr\//) {
                       if (!grep(/^cr$/,@{$roles})) {
                           next;
                       }
                   } else {
                       next;
                   }
             }              }
         }          }
  $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;          if ($withsec) {
               $returnhash{$username.':'.$domain.':'.$role.':'.$section} =
                   $tstart.':'.$tend;
           } else {
               $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
           }
     }      }
     return %returnhash;      return %returnhash;
 }  }
Line 2502  sub getannounce { Line 2530  sub getannounce {
 #  #
   
 sub courseidput {  sub courseidput {
     my ($domain,$storehash,$coursehome)=@_;      my ($domain,$storehash,$coursehome,$caller) = @_;
     my $items='';      my $outcome;
     my $now = time;      if ($caller eq 'timeonly') {
     foreach my $item (keys(%$storehash)) {          my $cids = '';
         $storehash->{$item}{'lasttime'} = $now;          foreach my $item (keys(%$storehash)) {
         $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';              $cids.=&escape($item).'&';
           }
           $cids=~s/\&$//;
           $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$cids,
                             $coursehome);       
       } else {
           my $items = '';
           foreach my $item (keys(%$storehash)) {
               $items.= &escape($item).'='.
                        &freeze_escape($$storehash{$item}).'&';
           }
           $items=~s/\&$//;
           $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$items,
                             $coursehome);
     }      }
     $items=~s/\&$//;  
     my $outcome = &reply('courseidputhash:'.$domain.':'.$items,$coursehome);  
     if ($outcome eq 'unknown_cmd') {      if ($outcome eq 'unknown_cmd') {
         my $what;          my $what;
         foreach my $cid (keys(%$storehash)) {          foreach my $cid (keys(%$storehash)) {
             $what .= &escape($cid).'=';              $what .= &escape($cid).'=';
             foreach my $item ('description','instcode','owner','type') {              foreach my $item ('description','inst_code','owner','type') {
                 $what .= $storehash->{$item}.':';                  $what .= &escape($storehash->{$item}).':';
             }              }
             $what =~ s/\:$/&/;              $what =~ s/\:$/&/;
         }          }
Line 2528  sub courseidput { Line 2567  sub courseidput {
 }  }
   
 sub courseiddump {  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
           $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
     my $as_hash = 1;      my $as_hash = 1;
     my %returnhash;      my %returnhash;
     if (!$domfilter) { $domfilter=''; }      if (!$domfilter) { $domfilter=''; }
Line 2545  sub courseiddump { Line 2585  sub courseiddump {
                          $sincefilter.':'.&escape($descfilter).':'.                           $sincefilter.':'.&escape($descfilter).':'.
                          &escape($instcodefilter).':'.&escape($ownerfilter).                           &escape($instcodefilter).':'.&escape($ownerfilter).
                          ':'.&escape($coursefilter).':'.&escape($typefilter).                           ':'.&escape($coursefilter).':'.&escape($typefilter).
                          ':'.&escape($regexp_ok).':'.$as_hash,$tryserver);                            ':'.&escape($regexp_ok).':'.$as_hash,$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 2555  sub courseiddump { Line 2595  sub courseiddump {
                     if (ref($result) eq 'HASH') {                      if (ref($result) eq 'HASH') {
                         $returnhash{$key}=$result;                          $returnhash{$key}=$result;
                     } else {                      } else {
                         my @responses = split(/:/,$result);                          my @responses = split(/:/,$value);
                         my @items = ('description','instcode','owner','type');                          my @items = ('description','inst_code','owner','type');
                         for (my $i=0; $i<@responses; $i++) {                          for (my $i=0; $i<@responses; $i++) {
                             $returnhash{$key}{$items[$i]} = $responses[$i];                              $returnhash{$key}{$items[$i]} = &unescape($responses[$i]);
                         }                          }
                     }                       } 
                 }                  }
Line 2606  sub get_domain_roles { Line 2646  sub get_domain_roles {
     if (undef($enddate) || $enddate eq '') {      if (undef($enddate) || $enddate eq '') {
         $enddate = '.';          $enddate = '.';
     }      }
     my $rolelist = join(':',@{$roles});      my $rolelist;
       if (ref($roles) eq 'ARRAY') {
           $rolelist = join(':',@{$roles});
       }
     my %personnel = ();      my %personnel = ();
   
     my %servers = &get_servers($dom,'library');      my %servers = &get_servers($dom,'library');
Line 2632  sub get_first_access { Line 2675  sub get_first_access {
     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);
     if ($type eq 'map') {      if ($type eq 'course') {
    $res='course';
       } elsif ($type eq 'map') {
  $res=&symbread($map);   $res=&symbread($map);
     } else {      } else {
  $res=$symb;   $res=$symb;
Line 2645  sub set_first_access { Line 2690  sub set_first_access {
     my ($type)=@_;      my ($type)=@_;
     my ($symb,$courseid,$udom,$uname)=&whichuser();      my ($symb,$courseid,$udom,$uname)=&whichuser();
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'map') {      if ($type eq 'course') {
    $res='course';
       } elsif ($type eq 'map') {
  $res=&symbread($map);   $res=&symbread($map);
     } else {      } else {
  $res=$symb;   $res=$symb;
Line 4801  sub auto_run { Line 4848  sub auto_run {
             $response = 1;              $response = 1;
         }          }
     } else {      } else {
         my $homeserver = &homeserver($cnum,$cdom);          my $homeserver;
         $response = &reply('autorun:'.$cdom,$homeserver);          if (&is_course($cdom,$cnum)) {
               $homeserver = &homeserver($cnum,$cdom);
           } else {
               $homeserver = &domain($cdom,'primary');
           }
           if ($homeserver ne 'no_host') {
               $response = &reply('autorun:'.$cdom,$homeserver);
           }
     }      }
     return $response;      return $response;
 }  }
Line 5208  sub assignrole { Line 5262  sub assignrole {
     } else {      } else {
         my $cwosec=$url;          my $cwosec=$url;
         $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;          $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
         unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) {           if (!(&allowed('c'.$role,$cwosec)) && !(&allowed('c'.$role,$udom))) {
            &logthis('Refused assignrole: '.              my $refused;
              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.              if (($env{'request.course.sec'}  ne '') && ($role eq 'st')) {
     $env{'user.name'}.' at '.$env{'user.domain'});                  if (!(&allowed('c'.$role,$url))) {
            return 'refused';                       $refused = 1;
                   }
               } else {
                   $refused = 1;
               }
               if ($refused) { 
                   &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
                            ' '.$role.' '.$end.' '.$start.' by '.
              $env{'user.name'}.' at '.$env{'user.domain'});
                   return 'refused';
               }
         }          }
         $mrole=$role;          $mrole=$role;
     }      }
Line 5546  sub createcourse { Line 5610  sub createcourse {
 # log existence  # log existence
     my $newcourse = {      my $newcourse = {
                     $udom.'_'.$uname => {                      $udom.'_'.$uname => {
                                      description => &escape($description),                                       description => $description,
                                      inst_code   => &escape($inst_code),                                       inst_code   => $inst_code,
                                      owner       => &escape($course_owner),                                       owner       => $course_owner,
                                      type        => &escape($crstype),                                       type        => $crstype,
                                                 },                                                  },
                     };                      };
     &courseidput($udom,$newcourse);      &courseidput($udom,$newcourse,$uhome,'notime');
     &flushcourselogs();  
 # set toplevel url  # set toplevel url
     my $topurl=$url;      my $topurl=$url;
     unless ($nonstandard) {      unless ($nonstandard) {
Line 6355  sub resdata { Line 6418  sub resdata {
     }      }
     if (!ref($result)) { return $result; }          if (!ref($result)) { return $result; }    
     foreach my $item (@which) {      foreach my $item (@which) {
  if (defined($result->{$item})) {   if (defined($result->{$item->[0]})) {
     return $result->{$item};      return [$result->{$item->[0]},$item->[1]];
  }   }
     }      }
     return undef;      return undef;
Line 6568  sub EXT { Line 6631  sub EXT {
 # ----------------------------------------------------------- first, check user  # ----------------------------------------------------------- first, check user
   
     my $userreply=&resdata($uname,$udom,'user',      my $userreply=&resdata($uname,$udom,'user',
        ($courselevelr,$courselevelm,         ([$courselevelr,'resource'],
  $courselevel));   [$courselevelm,'map'     ],
     if (defined($userreply)) { return $userreply; }   [$courselevel, 'course'  ]));
       if (defined($userreply)) { return &get_reply($userreply); }
   
 # ------------------------------------------------ second, check some of course  # ------------------------------------------------ second, check some of course
             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);                                         $mapparm,$spacequalifierrest);
                 if (defined($coursereply)) { return $coursereply; }                  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',
      ($seclevelr,$seclevelm,$seclevel,    ([$seclevelr,   'resource'],
       $courselevelr));     [$seclevelm,   'map'     ],
     if (defined($coursereply)) { return $coursereply; }     [$seclevel,    'course'  ],
      [$courselevelr,'resource']));
       if (defined($coursereply)) { return &get_reply($coursereply); }
   
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
     my %parmhash=();      my %parmhash=();
Line 6596  sub EXT { Line 6662  sub EXT {
  $thisparm=$parmhash{$symbparm};   $thisparm=$parmhash{$symbparm};
  untie(%parmhash);   untie(%parmhash);
     }      }
     if ($thisparm) { return $thisparm; }      if ($thisparm) { return &get_reply([$thisparm,'resource']); }
  }   }
 # ------------------------------------------ fourth, look in resource metadata  # ------------------------------------------ fourth, look in resource metadata
   
Line 6609  sub EXT { Line 6675  sub EXT {
     $filename=$env{'request.filename'};      $filename=$env{'request.filename'};
  }   }
  my $metadata=&metadata($filename,$spacequalifierrest);   my $metadata=&metadata($filename,$spacequalifierrest);
  if (defined($metadata)) { return $metadata; }   if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
  $metadata=&metadata($filename,'parameter_'.$spacequalifierrest);   $metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
  if (defined($metadata)) { return $metadata; }   if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
   
 # ---------------------------------------------- fourth, look in rest pf course  # ---------------------------------------------- fourth, 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',
      ($courselevelm,$courselevel));       ([$courselevelm,'map'   ],
     if (defined($coursereply)) { return $coursereply; }        [$courselevel, 'course']));
       if (defined($coursereply)) { return &get_reply($coursereply); }
  }   }
 # ------------------------------------------------------------------ Cascade up  # ------------------------------------------------------------------ Cascade up
  unless ($space eq '0') {   unless ($space eq '0') {
Line 6628  sub EXT { Line 6695  sub EXT {
     my $id=pop(@parts);      my $id=pop(@parts);
     my $part=join('_',@parts);      my $part=join('_',@parts);
     if ($part eq '') { $part='0'; }      if ($part eq '') { $part='0'; }
     my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,      my @partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
  $symbparm,$udom,$uname,$section,1);   $symbparm,$udom,$uname,$section,1);
     if (defined($partgeneral)) { return $partgeneral; }      if (@partgeneral) { return &get_reply(\@partgeneral); }
  }   }
  if ($recurse) { return undef; }   if ($recurse) { return undef; }
  my $pack_def=&packages_tab_default($filename,$varname);   my $pack_def=&packages_tab_default($filename,$varname);
  if (defined($pack_def)) { return $pack_def; }   if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }
   
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {      } elsif ($realm eq 'environment') {
 # ----------------------------------------------------------------- environment  # ----------------------------------------------------------------- environment
Line 6663  sub EXT { Line 6729  sub EXT {
     return '';      return '';
 }  }
   
   sub get_reply {
       my ($reply_value) = @_;
       if (wantarray) {
    return @$reply_value;
       }
       return $reply_value->[0];
   }
   
 sub check_group_parms {  sub check_group_parms {
     my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;      my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
     my @groupitems = ();      my @groupitems = ();
     my $resultitem;      my $resultitem;
     my @levels = ($symbparm,$mapparm,$what);      my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$what,'course']);
     foreach my $group (@{$groups}) {      foreach my $group (@{$groups}) {
         foreach my $level (@levels) {          foreach my $level (@levels) {
              my $item = $courseid.'.['.$group.'].'.$level;               my $item = $courseid.'.['.$group.'].'.$level->[0];
              push(@groupitems,$item);               push(@groupitems,[$item,$level->[1]]);
         }          }
     }      }
     my $coursereply = &resdata($env{'course.'.$courseid.'.num'},      my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
Line 6764  sub metadata { Line 6838  sub metadata {
     if (($uri eq '') ||       if (($uri eq '') || 
  (($uri =~ m|^/*adm/|) &&    (($uri =~ m|^/*adm/|) && 
      ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||       ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) ) {
  ($uri =~ m|home/$match_username/public_html/|)) {   return undef;
       }
       if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) 
    && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {
  return undef;   return undef;
     }      }
     my $filename=$uri;      my $filename=$uri;
Line 6786  sub metadata { Line 6863  sub metadata {
 # if (! exists($metacache{$uri})) {  # if (! exists($metacache{$uri})) {
 #    $metacache{$uri}={};  #    $metacache{$uri}={};
 # }  # }
    my $cachetime = 60*60;
         if ($liburi) {          if ($liburi) {
     $liburi=&declutter($liburi);      $liburi=&declutter($liburi);
             $filename=$liburi;              $filename=$liburi;
Line 6796  sub metadata { Line 6874  sub metadata {
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring;   my $metastring;
  if ($uri !~ m -^(editupload)/-) {   if ($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) {
       my $which = &hreflocation('','/'.($liburi || $uri));
       $metastring = 
    &Apache::lonnet::ssi_body($which,
     ('grade_target' => 'meta'));
       $cachetime = 1; # only want this cached in the child not long term
    } elsif ($uri !~ m -^(editupload)/-) {
     my $file=&filelocation('',&clutter($filename));      my $file=&filelocation('',&clutter($filename));
     #push(@{$metaentry{$uri.'.file'}},$file);      #push(@{$metaentry{$uri.'.file'}},$file);
     $metastring=&getfile($file);      $metastring=&getfile($file);
Line 6963  sub metadata { Line 7047  sub metadata {
  $metaentry{':keys'} = join(',',keys(%metathesekeys));   $metaentry{':keys'} = join(',',keys(%metathesekeys));
  &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);   &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
  $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);   $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
  &do_cache_new('meta',$uri,\%metaentry,60*60);   &do_cache_new('meta',$uri,\%metaentry,$cachetime);
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metaentry{':'.$what};      return $metaentry{':'.$what};
Line 7911  sub filelocation { Line 7995  sub filelocation {
         }          }
     }      }
     $location=~s://+:/:g; # remove duplicate /      $location=~s://+:/:g; # remove duplicate /
     while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..      while ($location=~m{/\.\./}) {
    if ($location =~ m{/[^/]+/\.\./}) {
       $location=~ s{/[^/]+/\.\./}{/}g;
    } else {
       $location=~ s{/\.\./}{/}g;
    }
       } #remove dir/..
     while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./      while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
     return $location;      return $location;
 }  }
Line 8777  explanation of a user role term Line 8867  explanation of a user role term
   
 =item *  =item *
   
 get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) :  get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) :
 All arguments are optional. Returns a hash of a roles, either for  All arguments are optional. Returns a hash of a roles, either for
 co-author/assistant author roles for a user's Construction Space  co-author/assistant author roles for a user's Construction Space
 (default), or if $context is 'userroles', roles for the user himself,  (default), or if $context is 'userroles', roles for the user himself,
 In the hash, keys are set to colon-sparated $uname,$udom,and $role,  In the hash, keys are set to colon-separated $uname,$udom,$role, and
 and value is set to colon-separated start and end times for the role.  (optionally) if $withsec is true, a fourth colon-separated item - $section.
 If no username and domain are specified, will default to current  For each key, value is set to colon-separated start and end times for
 user/domain. Types, roles, and roledoms are references to arrays,  the role.  If no username and domain are specified, will default to
   current user/domain. Types, roles, and roledoms are references to arrays
 of role statuses (active, future or previous), roles   of role statuses (active, future or previous), roles 
 (e.g., cc,in, st etc.) and domains of the roles which can be used  (e.g., cc,in, st etc.) and domains of the roles which can be used
 to restrict the list of roles reported. If no array ref is   to restrict the list of roles reported. If no array ref is 
Removed from v.1.918  
changed lines
  Added in v.1.935

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