[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.452 and 1.478

version 1.452, 2003/12/04 20:09:35 version 1.478, 2004/03/16 21:29:31
Line 377  sub delenv { Line 377  sub delenv {
     return 'error: '.$!;      return 'error: '.$!;
  }   }
  foreach (@oldenv) {   foreach (@oldenv) {
     unless ($_=~/^$delthis/) { print $fh $_; }      if ($_=~/^$delthis/) { 
                   my ($key,undef) = split('=',$_);
                   delete($ENV{$key});
               } else {
                   print $fh $_; 
               }
  }   }
  close($fh);   close($fh);
     }      }
Line 506  sub changepass { Line 511  sub changepass {
   
 sub queryauthenticate {  sub queryauthenticate {
     my ($uname,$udom)=@_;      my ($uname,$udom)=@_;
     if (($perlvar{'lonRole'} eq 'library') &&       my $uhome=&homeserver($uname,$udom);
         ($udom eq $perlvar{'lonDefDomain'})) {      if (!$uhome) {
  my $answer=reply("encrypt:currentauth:$udom:$uname",   &logthis("User $uname at $udom is unknown when looking for authentication mechanism");
  $perlvar{'lonHostID'});   return 'no_host';
  unless ($answer eq 'unknown_user' or $answer eq 'refused') {      }
     if (length($answer)) {      my $answer=reply("encrypt:currentauth:$udom:$uname",$uhome);
  return $answer;      if ($answer =~ /^(unknown_user|refused|con_lost)/) {
     }   &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
     else {  
  &logthis("User $uname at $udom lacks an authentication mechanism");  
  return 'no_host';  
     }  
  }  
     }  
   
     my $tryserver;  
     foreach $tryserver (keys %libserv) {  
  if ($hostdom{$tryserver} eq $udom) {  
            my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver);  
    unless ($answer eq 'unknown_user' or $answer eq 'refused') {  
        if (length($answer)) {  
    return $answer;  
        }  
        else {  
    &logthis("User $uname at $udom lacks an authentication mechanism");  
    return 'no_host';  
        }  
    }  
        }  
     }      }
     &logthis("User $uname at $udom lacks an authentication mechanism");          return $answer;
     return 'no_host';  
 }  }
   
 # --------- Try to authenticate user from domain's lib servers (first this one)  # --------- Try to authenticate user from domain's lib servers (first this one)
Line 546  sub authenticate { Line 529  sub authenticate {
     my ($uname,$upass,$udom)=@_;      my ($uname,$upass,$udom)=@_;
     $upass=escape($upass);      $upass=escape($upass);
     $uname=~s/\W//g;      $uname=~s/\W//g;
     if (($perlvar{'lonRole'} eq 'library') &&       my $uhome=&homeserver($uname,$udom);
         ($udom eq $perlvar{'lonDefDomain'})) {      if (!$uhome) {
     my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});   &logthis("User $uname at $udom is unknown in authenticate");
         if ($answer =~ /authorized/) {   return 'no_host';
               if ($answer eq 'authorized') {      }
                  &logthis("User $uname at $udom authorized by local server");       my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);
                  return $perlvar{'lonHostID'};       if ($answer eq 'authorized') {
               }   &logthis("User $uname at $udom authorized by $uhome"); 
               if ($answer eq 'non_authorized') {   return $uhome; 
                  &logthis("User $uname at $udom rejected by local server");       }
                  return 'no_host';       if ($answer eq 'non_authorized') {
               }   &logthis("User $uname at $udom rejected by $uhome");
  }   return 'no_host'; 
     }  
   
     my $tryserver;  
     foreach $tryserver (keys %libserv) {  
  if ($hostdom{$tryserver} eq $udom) {  
            my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);  
            if ($answer =~ /authorized/) {  
               if ($answer eq 'authorized') {  
                  &logthis("User $uname at $udom authorized by $tryserver");   
                  return $tryserver;   
               }  
               if ($answer eq 'non_authorized') {  
                  &logthis("User $uname at $udom rejected by $tryserver");  
                  return 'no_host';  
               }   
    }  
        }  
     }      }
     &logthis("User $uname at $udom could not be authenticated");          &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
     return 'no_host';      return 'no_host';
 }  }
   
Line 1205  sub tokenwrapper { Line 1171  sub tokenwrapper {
     $uri=~s/^\///;      $uri=~s/^\///;
     $ENV{'user.environment'}=~/\/([^\/]+)\.id/;      $ENV{'user.environment'}=~/\/([^\/]+)\.id/;
     my $token=$1;      my $token=$1;
     if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {  #    if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {
       if ($uri=~m|^uploaded/([^/]+)/([^/]+)/(.+)(\?\.*)*$|) {
  &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});   &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});
         return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.          return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
                (($uri=~/\?/)?'&':'?').'token='.$token.                 (($uri=~/\?/)?'&':'?').'token='.$token.
Line 1214  sub tokenwrapper { Line 1181  sub tokenwrapper {
  return '/adm/notfound.html';   return '/adm/notfound.html';
     }      }
 }  }
       
   # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
   # input: action, courseID, current domain, home server for course, intended
   #        path to file, source of file.
   # output: ok if successful, diagnostic message otherwise
   #
   # Allows directory structure to be used within lonUsers/../userfiles/ for a 
   # course.
   #
   # action = propagate - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
   #          will be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles in
   #          course's home server.
   #
   # action = copy - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will
   #          be copied from $source (current location) to 
   #          /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
   #         and will then be copied to
   #          /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in
   #         course's home server.
   
   sub process_coursefile {
       my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_;
       my $fetchresult;
       if ($action eq 'propagate') {
           $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file
                               ,$docuhome);
       } elsif ($action eq 'copy') {
           my $fetchresult = '';
           my $fpath = '';
           my $fname = $file;
           ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
           $fpath=$docudom.'/'.$docuname.'/'.$fpath;
           my $filepath=$perlvar{'lonDocRoot'}.'/userfiles';
           unless ($fpath eq '') {
               my @parts=split('/',$fpath);
               foreach my $part (@parts) {
                   $filepath.= '/'.$part;
                   if ((-e $filepath)!=1) {
                       mkdir($filepath,0777);
                   }
               }
           }
           if ($source eq '') {
               $fetchresult = 'no source file';
           } else {
               my $destination = $filepath.'/'.$fname;
               print STDERR "Getting ready to rename $source to $destination\n";
               rename($source,$destination);
               $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
                                    $docuhome);
           }
       }
       unless ( ($fetchresult eq 'ok') || ($fetchresult eq 'no source file') ) {
           &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
                ' to host '.$docuhome.': '.$fetchresult);
       }
       return $fetchresult;
   }
   
 # --------------- Take an uploaded file and put it into the userfiles directory  # --------------- Take an uploaded file and put it into the userfiles directory
 # input: name of form element, coursedoc=1 means this is for the course  # input: name of form element, coursedoc=1 means this is for the course
 # output: url of file in userspace  # output: url of file in userspace
Line 1270  sub finishuserfileupload { Line 1295  sub finishuserfileupload {
     }      }
 # Notify homeserver to grep it  # Notify homeserver to grep it
 #  #
           my $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,
     my $fetchresult=       $docuhome);
  &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome);  
     if ($fetchresult eq 'ok') {      if ($fetchresult eq 'ok') {
 #  #
 # Return the URL to it  # Return the URL to it
Line 1341  sub flushcourselogs { Line 1365  sub flushcourselogs {
 # Writes to the dynamic metadata of resources to get hit counts, etc.  # Writes to the dynamic metadata of resources to get hit counts, etc.
 #  #
     foreach my $entry (keys(%accesshash)) {      foreach my $entry (keys(%accesshash)) {
         my ($dom,$name,undef,$type)=($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);          if ($entry =~ /___count$/) {
         if ($type eq 'count'){              my ($dom,$name);
               ($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:);
               if (! defined($dom) || $dom eq '' || 
                   ! defined($name) || $name eq '') {
                   my $cid = $ENV{'request.course.id'};
                   $dom  = $ENV{'request.'.$cid.'.domain'};
                   $name = $ENV{'request.'.$cid.'.num'};
               }
             my $value = $accesshash{$entry};              my $value = $accesshash{$entry};
             my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/);              my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/);
             my %temphash=($url => $value);              my %temphash=($url => $value);
Line 1357  sub flushcourselogs { Line 1388  sub flushcourselogs {
                 }                  }
             }              }
         } else {          } else {
               my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);
             my %temphash=($entry => $accesshash{$entry});              my %temphash=($entry => $accesshash{$entry});
             if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {              if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
                 delete $accesshash{$entry};                  delete $accesshash{$entry};
Line 1397  sub courselog { Line 1429  sub courselog {
     } else {      } else {
  $courselogs{$ENV{'request.course.id'}}.=$what;   $courselogs{$ENV{'request.course.id'}}.=$what;
     }      }
 #    if (length($courselogs{$ENV{'request.course.id'}})>4048) {      if (length($courselogs{$ENV{'request.course.id'}})>4048) {
     if (length($courselogs{$ENV{'request.course.id'}})>48) {  
  &flushcourselogs();   &flushcourselogs();
     }      }
 }  }
Line 1420  sub courseacclog { Line 1451  sub courseacclog {
   
 sub countacc {  sub countacc {
     my $url=&declutter(shift);      my $url=&declutter(shift);
       return if (! defined($url) || $url eq '');
     unless ($ENV{'request.course.id'}) { return ''; }      unless ($ENV{'request.course.id'}) { return ''; }
     $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;      $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;
     my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';      my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
Line 1438  sub userrolelog { Line 1470  sub userrolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend)=@_;      my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
     if (($trole=~/^ca/) || ($trole=~/^in/) ||       if (($trole=~/^ca/) || ($trole=~/^in/) || 
         ($trole=~/^cc/) || ($trole=~/^ep/) ||          ($trole=~/^cc/) || ($trole=~/^ep/) ||
         ($trole=~/^cr/)) {          ($trole=~/^cr/) || ($trole=~/^ta/)) {
        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);         my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
        $userrolehash         $userrolehash
          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
Line 1450  sub get_course_adv_roles { Line 1482  sub get_course_adv_roles {
     my $cid=shift;      my $cid=shift;
     $cid=$ENV{'request.course.id'} unless (defined($cid));      $cid=$ENV{'request.course.id'} unless (defined($cid));
     my %coursehash=&coursedescription($cid);      my %coursehash=&coursedescription($cid);
       my %nothide=();
       foreach (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
    $nothide{join(':',split(/[\@\:]/,$_))}=1;
       }
     my %returnhash=();      my %returnhash=();
     my %dumphash=      my %dumphash=
             &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});              &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
Line 1460  sub get_course_adv_roles { Line 1496  sub get_course_adv_roles {
         if (($tend) && ($tend<$now)) { next; }          if (($tend) && ($tend<$now)) { next; }
         if (($tstart) && ($now<$tstart)) { next; }          if (($tstart) && ($now<$tstart)) { next; }
         my ($role,$username,$domain,$section)=split(/\:/,$_);          my ($role,$username,$domain,$section)=split(/\:/,$_);
    if ((&privileged($username,$domain)) && 
       (!$nothide{$username.':'.$domain})) { next; }
         my $key=&plaintext($role);          my $key=&plaintext($role);
         if ($section) { $key.=' (Sec/Grp '.$section.')'; }          if ($section) { $key.=' (Sec/Grp '.$section.')'; }
         if ($returnhash{$key}) {          if ($returnhash{$key}) {
Line 2141  sub coursedescription { Line 2179  sub coursedescription {
     return %returnhash;      return %returnhash;
 }  }
   
   # -------------------------------------------------See if a user is privileged
   
   sub privileged {
       my ($username,$domain)=@_;
       my $rolesdump=&reply("dump:$domain:$username:roles",
    &homeserver($username,$domain));
       if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; }
       my $now=time;
       if ($rolesdump ne '') {
           foreach (split(/&/,$rolesdump)) {
       if ($_!~/^rolesdef\&/) {
    my ($area,$role)=split(/=/,$_);
    $area=~s/\_\w\w$//;
    my ($trole,$tend,$tstart)=split(/_/,$role);
    if (($trole eq 'dc') || ($trole eq 'su')) {
       my $active=1;
       if ($tend) {
    if ($tend<$now) { $active=0; }
       }
       if ($tstart) {
    if ($tstart>$now) { $active=0; }
       }
       if ($active) { return 1; }
    }
       }
    }
       }
       return 0;
   }
   
 # -------------------------------------------------------- Get user privileges  # -------------------------------------------------------- Get user privileges
   
 sub rolesinit {  sub rolesinit {
Line 3144  sub modifyuser { Line 3212  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)=@_;          $end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_;
     my $cid='';      if (!$cid) {
     unless ($cid=$ENV{'request.course.id'}) {   unless ($cid=$ENV{'request.course.id'}) {
  return 'not_in_class';      return 'not_in_class';
    }
     }      }
 # --------------------------------------------------------------- Make the user  # --------------------------------------------------------------- Make the user
     my $reply=&modifyuser      my $reply=&modifyuser
Line 3157  sub modifystudent { Line 3226  sub modifystudent {
     # This will cause &modify_student_enrollment to get the uid from the      # This will cause &modify_student_enrollment to get the uid from the
     # students environment      # students environment
     $uid = undef if (!$forceid);      $uid = undef if (!$forceid);
     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,      $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
                                         $last,$gene,$usec,$end,$start);   $gene,$usec,$end,$start,$type,$cid);
     return $reply;      return $reply;
 }  }
   
 sub modify_student_enrollment {  sub modify_student_enrollment {
     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start) = @_;      my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
     # Get the course id from the environment   $cid) = @_;
     my $cid='';      my ($cdom,$cnum,$chome);
     unless ($cid=$ENV{'request.course.id'}) {      if (!$cid) {
  return 'not_in_class';   unless ($cid=$ENV{'request.course.id'}) {
       return 'not_in_class';
    }
    $cdom=$ENV{'course.'.$cid.'.domain'};
    $cnum=$ENV{'course.'.$cid.'.num'};
       } else {
    ($cdom,$cnum)=split(/_/,$cid);
     }      }
       $chome=$ENV{'course.'.$cid.'.home'};
       if (!$chome) {
    $chome=&homeserver($cnum,$cdom);
       }
       if (!$chome) { return 'unknown_course'; }
     # Make sure the user exists      # Make sure the user exists
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom);
     if (($uhome eq '') || ($uhome eq 'no_host')) {       if (($uhome eq '') || ($uhome eq 'no_host')) { 
  return 'error: no such user';   return 'error: no such user';
     }      }
     #  
     # Get student data if we were not given enough information      # Get student data if we were not given enough information
     if (!defined($first)  || $first  eq '' ||       if (!defined($first)  || $first  eq '' || 
         !defined($last)   || $last   eq '' ||           !defined($last)   || $last   eq '' || 
Line 3187  sub modify_student_enrollment { Line 3266  sub modify_student_enrollment {
                        ['firstname','middlename','lastname', 'generation','id']                         ['firstname','middlename','lastname', 'generation','id']
                        ,$udom,$uname);                         ,$udom,$uname);
   
         foreach (keys(%tmp)) {          #foreach (keys(%tmp)) {
             &logthis("key $_ = ".$tmp{$_});          #    &logthis("key $_ = ".$tmp{$_});
         }          #}
         $first  = $tmp{'firstname'}  if (!defined($first)  || $first  eq '');          $first  = $tmp{'firstname'}  if (!defined($first)  || $first  eq '');
         $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');          $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');
         $last   = $tmp{'lastname'}   if (!defined($last)   || $last eq '');          $last   = $tmp{'lastname'}   if (!defined($last)   || $last eq '');
Line 3198  sub modify_student_enrollment { Line 3277  sub modify_student_enrollment {
     }      }
     my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,      my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,
                                                            $first,$middle);                                                             $first,$middle);
     my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.      my $value=&escape($uname.':'.$udom).'='.
               $ENV{'course.'.$cid.'.num'}.':classlist:'.   &escape(join(':',$end,$start,$uid,$usec,$fullname,$type));
                       &escape($uname.':'.$udom).'='.      my $reply=critical('put:'.$cdom.':'.$cnum.':classlist:'.$value,$chome);
                       &escape(join(':',$end,$start,$uid,$usec,$fullname)),  
               $ENV{'course.'.$cid.'.home'});  
     unless (($reply eq 'ok') || ($reply eq 'delayed')) {      unless (($reply eq 'ok') || ($reply eq 'delayed')) {
  return 'error: '.$reply;   return 'error: '.$reply;
     }      }
Line 3694  sub EXT { Line 3771  sub EXT {
  my $hashid="$udom:$uname";   my $hashid="$udom:$uname";
  my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,   my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,
  'userres');   'userres');
  if (!defined($cached)) {    if (!defined($cached)) {
     my %resourcedata=&get('resourcedata',      my %resourcedata=&dump('resourcedata',$udom,$uname);
   [$courselevelr,$courselevelm,  
    $courselevel],$udom,$uname);  
     $result=\%resourcedata;      $result=\%resourcedata;
     &do_cache(\%userresdatacache,$hashid,$result,'userres');      &do_cache(\%userresdatacache,$hashid,$result,'userres');
  }   }
Line 3710  sub EXT { Line 3785  sub EXT {
     if ($$result{$courselevel}) {      if ($$result{$courselevel}) {
  return $$result{$courselevel}; }   return $$result{$courselevel}; }
  } else {   } else {
     if ($tmp!~/No such file/) {      #error 2 occurs when the .db doesn't exist
       if ($tmp!~/error: 2 /) {
  &logthis("<font color=blue>WARNING:".   &logthis("<font color=blue>WARNING:".
  " Trying to get resource data for ".   " Trying to get resource data for ".
  $uname." at ".$udom.": ".   $uname." at ".$udom.": ".
  $tmp."</font>");   $tmp."</font>");
     } elsif ($tmp=~/error:No such file/) {      } elsif ($tmp=~/error: 2 /) {
                         &EXT_cache_set($udom,$uname);                          &EXT_cache_set($udom,$uname);
     } elsif ($tmp =~ /^(con_lost|no_such_host)/) {      } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
  return $tmp;   return $tmp;
Line 3797  sub packages_tab_default { Line 3873  sub packages_tab_default {
     my $packages=&metadata($uri,'packages');      my $packages=&metadata($uri,'packages');
     foreach my $package (split(/,/,$packages)) {      foreach my $package (split(/,/,$packages)) {
  my ($pack_type,$pack_part)=split(/_/,$package,2);   my ($pack_type,$pack_part)=split(/_/,$package,2);
  if ($pack_part eq $part) {   if (defined($packagetab{"$pack_type&$name&default"})) {
     return $packagetab{"$pack_type&$name&default"};      return $packagetab{"$pack_type&$name&default"};
  }   }
    if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {
       return $packagetab{$pack_type."_".$pack_part."&$name&default"};
    }
     }      }
     return undef;      return undef;
 }  }
Line 3828  sub metadata { Line 3907  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 '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||      if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
  ($uri =~ m|home/[^/]+/public_html/|)) {   ($uri =~ m|home/[^/]+/public_html/|) || ($uri =~ m|^uploaded/|)) {
  return '';   return undef;
     }      }
     my $filename=$uri;      my $filename=$uri;
     $uri=~s/\.meta$//;      $uri=~s/\.meta$//;
Line 3846  sub metadata { Line 3925  sub metadata {
 #  #
 # Is this a recursive call for a library?  # Is this a recursive call for a library?
 #  #
  my %lcmetacache;   if (! exists($metacache{$uri})) {
       $metacache{$uri}={};
    }
         if ($liburi) {          if ($liburi) {
     $liburi=&declutter($liburi);      $liburi=&declutter($liburi);
             $filename=$liburi;              $filename=$liburi;
Line 3870  sub metadata { Line 3951  sub metadata {
     if (defined($token->[2]->{'id'})) {       if (defined($token->[2]->{'id'})) { 
  $keyroot.='_'.$token->[2]->{'id'};    $keyroot.='_'.$token->[2]->{'id'}; 
     }      }
     if ($lcmetacache{':packages'}) {      if ($metacache{$uri}->{':packages'}) {
  $lcmetacache{':packages'}.=','.$package.$keyroot;   $metacache{$uri}->{':packages'}.=','.$package.$keyroot;
     } else {      } else {
  $lcmetacache{':packages'}=$package.$keyroot;   $metacache{$uri}->{':packages'}=$package.$keyroot;
     }      }
     foreach (keys %packagetab) {      foreach (keys %packagetab) {
  my $part=$keyroot;   my $part=$keyroot;
Line 3895  sub metadata { Line 3976  sub metadata {
     if ($subp eq 'display') {      if ($subp eq 'display') {
  $value.=' [Part: '.$part.']';   $value.=' [Part: '.$part.']';
     }      }
     $lcmetacache{':'.$unikey.'.part'}=$part;      $metacache{$uri}->{':'.$unikey.'.part'}=$part;
     $metathesekeys{$unikey}=1;      $metathesekeys{$unikey}=1;
     unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) {      unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
  $lcmetacache{':'.$unikey.'.'.$subp}=$value;   $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
     }      }
     if (defined($lcmetacache{':'.$unikey.'.default'})) {      if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
  $lcmetacache{':'.$unikey}=   $metacache{$uri}->{':'.$unikey}=
     $lcmetacache{':'.$unikey.'.default'};      $metacache{$uri}->{':'.$unikey.'.default'};
     }      }
  }   }
     }      }
Line 3935  sub metadata { Line 4016  sub metadata {
     foreach (sort(split(/\,/,&metadata($uri,'keys',      foreach (sort(split(/\,/,&metadata($uri,'keys',
        $location,$unikey,         $location,$unikey,
        $depthcount+1)))) {         $depthcount+1)))) {
    $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
  $metathesekeys{$_}=1;   $metathesekeys{$_}=1;
     }      }
  }   }
Line 3945  sub metadata { Line 4027  sub metadata {
  }   }
  $metathesekeys{$unikey}=1;   $metathesekeys{$unikey}=1;
  foreach (@{$token->[3]}) {   foreach (@{$token->[3]}) {
     $lcmetacache{':'.$unikey.'.'.$_}=$token->[2]->{$_};      $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_};
  }   }
  my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));   my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
  my $default=$lcmetacache{':'.$unikey.'.default'};   my $default=$metacache{$uri}->{':'.$unikey.'.default'};
  if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {   if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
  # only ws inside the tag, and not in default, so use default   # only ws inside the tag, and not in default, so use default
  # as value   # as value
     $lcmetacache{':'.$unikey}=$default;      $metacache{$uri}->{':'.$unikey}=$default;
  } else {   } else {
   # either something interesting inside the tag or default    # either something interesting inside the tag or default
                   # uninteresting                    # uninteresting
     $lcmetacache{':'.$unikey}=$internaltext;      $metacache{$uri}->{':'.$unikey}=$internaltext;
  }   }
 # end of not-a-package not-a-library import  # end of not-a-package not-a-library import
     }      }
Line 3966  sub metadata { Line 4048  sub metadata {
     }      }
  }   }
 # are there custom rights to evaluate  # are there custom rights to evaluate
  if ($lcmetacache{':copyright'} eq 'custom') {   if ($metacache{$uri}->{':copyright'} eq 'custom') {
   
     #      #
     # Importing a rights file here      # Importing a rights file here
     #      #
     unless ($depthcount) {      unless ($depthcount) {
  my $location=$lcmetacache{':customdistributionfile'};   my $location=$metacache{$uri}->{':customdistributionfile'};
  my $dir=$filename;   my $dir=$filename;
  $dir=~s|[^/]*$||;   $dir=~s|[^/]*$||;
  $location=&filelocation($dir,$location);   $location=&filelocation($dir,$location);
  foreach (sort(split(/\,/,&metadata($uri,'keys',   foreach (sort(split(/\,/,&metadata($uri,'keys',
    $location,'_rights',     $location,'_rights',
    $depthcount+1)))) {     $depthcount+1)))) {
       $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
     $metathesekeys{$_}=1;      $metathesekeys{$_}=1;
  }   }
     }      }
  }   }
  $lcmetacache{':keys'}=join(',',keys %metathesekeys);   $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys);
  &metadata_generate_part0(\%metathesekeys,\%lcmetacache,$uri);   &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri);
  $lcmetacache{':allpossiblekeys'}=join(',',keys %metathesekeys);   $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys);
  &do_cache(\%metacache,$uri,\%lcmetacache,'meta');   &do_cache(\%metacache,$uri,$metacache{$uri},'meta');
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metacache{$uri}->{':'.$what};      return $metacache{$uri}->{':'.$what};
Line 4373  sub setup_random_from_rndseed { Line 4456  sub setup_random_from_rndseed {
     }      }
 }  }
   
   sub latest_receipt_algorithm_id {
       return 'receipt2';
   }
   
 sub ireceipt {  sub ireceipt {
     my ($funame,$fudom,$fucourseid,$fusymb)=@_;      my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;
     my $cuname=unpack("%32C*",$funame);      my $cuname=unpack("%32C*",$funame);
     my $cudom=unpack("%32C*",$fudom);      my $cudom=unpack("%32C*",$fudom);
     my $cucourseid=unpack("%32C*",$fucourseid);      my $cucourseid=unpack("%32C*",$fucourseid);
     my $cusymb=unpack("%32C*",$fusymb);      my $cusymb=unpack("%32C*",$fusymb);
     my $cunique=unpack("%32C*",$perlvar{'lonReceipt'});      my $cunique=unpack("%32C*",$perlvar{'lonReceipt'});
     return unpack("%32C*",$perlvar{'lonHostID'}).'-'.      my $cpart=unpack("%32S*",$part);
            ($cunique%$cuname+      my $return =unpack("%32C*",$perlvar{'lonHostID'}).'-';
             $cunique%$cudom+      if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
             $cusymb%$cuname+   $ENV{'request.state'} eq 'construct') {
             $cusymb%$cudom+   &Apache::lonxml::debug("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname).
             $cucourseid%$cuname+         " and ".($cpart%$cudom));
             $cucourseid%$cudom);         
    $return.= ($cunique%$cuname+
      $cunique%$cudom+
      $cusymb%$cuname+
      $cusymb%$cudom+
      $cucourseid%$cuname+
      $cucourseid%$cudom+
      $cpart%$cuname+
      $cpart%$cudom);
       } else {
    $return.= ($cunique%$cuname+
      $cunique%$cudom+
      $cusymb%$cuname+
      $cusymb%$cudom+
      $cucourseid%$cuname+
      $cucourseid%$cudom);
       }
       return $return;
 }  }
   
 sub receipt {  sub receipt {
   my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();      my ($part)=@_;
   return &ireceipt($name,$domain,$courseid,$symb);      my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();
       return &ireceipt($name,$domain,$courseid,$symb,$part);
 }  }
   
 # ------------------------------------------------------------ Serves up a file  # ------------------------------------------------------------ Serves up a file
 # returns either the contents of the file or a -1  # returns either the contents of the file or 
   # -1 if the file doesn't exist
   # -2 if an error occured when trying to aqcuire the file
   
 sub getfile {  sub getfile {
  my $file=shift;      my $file=shift;
  if ($file=~/^\/*uploaded\//) { # user file      if ($file=~/^\/*uploaded\//) { # user file
     my $ua=new LWP::UserAgent;   my $ua=new LWP::UserAgent;
     my $request=new HTTP::Request('GET',&tokenwrapper($file));   my $request=new HTTP::Request('GET',&tokenwrapper($file));
     my $response=$ua->request($request);   my $response=$ua->request($request);
     if ($response->is_success()) {   if ($response->is_success()) {
        return $response->content;      return $response->content;
     } else {    } else { 
        return -1;       #&logthis("Return Code is ".$response->code." for $file ".
     }      #         &tokenwrapper($file));
  } else { # normal file from res space      # 500 for ISE when tokenwrapper can't figure out what server to
   &repcopy($file);              #  contact
   if (! -e $file ) { return -1; };              # 503 when lonuploadacc can't contact the requested server
   my $fh;      if ($response->code eq 503 || $response->code eq 500) {
   open($fh,"<$file");   return -2;
   my $a='';      } else {
   while (<$fh>) { $a .=$_; }   return -1;
   return $a;      }
  }   }
       } else { # normal file from res space
    &repcopy($file);
    if (! -e $file ) { return -1; };
    my $fh;
    open($fh,"<$file");
    my $a='';
    while (<$fh>) { $a .=$_; }
    return $a;
       }
 }  }
   
 sub filelocation {  sub filelocation {
Line 4429  sub filelocation { Line 4546  sub filelocation {
     $location=$file;      $location=$file;
   } else {    } else {
     $file=~s/^$perlvar{'lonDocRoot'}//;      $file=~s/^$perlvar{'lonDocRoot'}//;
     $file=~s:^/*res::;      $file=~s:^/res/:/:;
     if ( !( $file =~ m:^/:) ) {      if ( !( $file =~ m:^/:) ) {
       $location = $dir. '/'.$file;        $location = $dir. '/'.$file;
     } else {      } else {
Line 4438  sub filelocation { Line 4555  sub filelocation {
   }    }
   $location=~s://+:/:g; # remove duplicate /    $location=~s://+:/:g; # remove duplicate /
   while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..    while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
     while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
   return $location;    return $location;
 }  }
   
 sub hreflocation {  sub hreflocation {
     my ($dir,$file)=@_;      my ($dir,$file)=@_;
     unless (($file=~/^http:\/\//i) || ($file=~/^\//)) {      unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
        my $finalpath=filelocation($dir,$file);   my $finalpath=filelocation($dir,$file);
        $finalpath=~s/^\/home\/httpd\/html//;   $finalpath=~s-^/home/httpd/html--;
        $finalpath=~s-/home/(\w+)/public_html/-/~$1/-;   $finalpath=~s-^/home/(\w+)/public_html/-/~$1/-;
        return $finalpath;   return $finalpath;
     } else {      } elsif ($file=~m-^/home-) {
        return $file;   $file=~s-^/home/httpd/html--;
    $file=~s-^/home/(\w+)/public_html/-/~$1/-;
    return $file;
       }
       return $file;
   }
   
   sub current_machine_domains {
       my $hostname=$hostname{$perlvar{'lonHostID'}};
       my @domains;
       while( my($id, $name) = each(%hostname)) {
   # &logthis("-$id-$name-$hostname-");
    if ($hostname eq $name) {
       push(@domains,$hostdom{$id});
    }
       }
       return @domains;
   }
   
   sub current_machine_ids {
       my $hostname=$hostname{$perlvar{'lonHostID'}};
       my @ids;
       while( my($id, $name) = each(%hostname)) {
   # &logthis("-$id-$name-$hostname-");
    if ($hostname eq $name) {
       push(@ids,$id);
    }
     }      }
       return @ids;
 }  }
   
 # ------------------------------------------------------------- Declutters URLs  # ------------------------------------------------------------- Declutters URLs
Removed from v.1.452  
changed lines
  Added in v.1.478

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