[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.267.4.3 and 1.301

version 1.267.4.3, 2002/08/30 20:33:58 version 1.301, 2002/11/18 15:16:35
Line 77  use Apache::File; Line 77  use Apache::File;
 use LWP::UserAgent();  use LWP::UserAgent();
 use HTTP::Headers;  use HTTP::Headers;
 use vars   use vars 
 qw(%perlvar %hostname %homecache %badServerCache %hostip %spareid %hostdom   qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
    %libserv %pr %prp %metacache %packagetab      %libserv %pr %prp %metacache %packagetab %titlecache 
    %courselogs %accesshash $processmarker $dumpcount      %courselogs %accesshash $processmarker $dumpcount 
    %coursedombuf %coursehombuf %courseresdatacache %domaindescription);     %coursedombuf %coursehombuf %courseresdatacache %domaindescription);
 use IO::Socket;  use IO::Socket;
Line 86  use GDBM_File; Line 86  use GDBM_File;
 use Apache::Constants qw(:common :http);  use Apache::Constants qw(:common :http);
 use HTML::LCParser;  use HTML::LCParser;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
   use Apache::loncoursedata;
   
 my $readit;  my $readit;
   
 # --------------------------------------------------------------------- Logging  # --------------------------------------------------------------------- Logging
Line 348  sub delenv { Line 350  sub delenv {
     return 'ok';      return 'ok';
 }  }
   
   # ------------------------------------------ Fight off request when overloaded
   
   sub overloaderror {
       my ($r,$checkserver)=@_;
       unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }
       my $loadavg;
       if ($checkserver eq $perlvar{'lonHostID'}) {
          my $loadfile=Apache::File->new('/proc/loadavg');
          $loadavg=<$loadfile>;
          $loadavg =~ s/\s.*//g;
          $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};
       } else {
          $loadavg=&reply('load',$checkserver);
       }
       my $overload=$loadavg-100;
       if ($overload>0) {
    $r->err_headers_out->{'Retry-After'}=$overload;
           $r->log_error('Overload of '.$overload.' on '.$checkserver);
           return 413;
       }    
       return '';
   }
   
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
       my $loadpercent = shift;
     my $tryserver;      my $tryserver;
     my $spareserver='';      my $spareserver='';
     my $lowestserver=100;      my $lowestserver=$loadpercent; 
     foreach $tryserver (keys %spareid) {      foreach $tryserver (keys %spareid) {
        my $answer=reply('load',$tryserver);         my $answer=reply('load',$tryserver);
        if (($answer =~ /\d/) && ($answer<$lowestserver)) {         if (($answer =~ /\d/) && ($answer<$lowestserver)) {
Line 567  sub idput { Line 593  sub idput {
   
 # ------------------------------------- Find the section of student in a course  # ------------------------------------- Find the section of student in a course
   
   sub getsection {
       my ($udom,$unam,$courseid)=@_;
       $courseid=~s/\_/\//g;
       $courseid=~s/^(\w)/\/$1/;
       my %Pending; 
       my %Expired;
       #
       # Each role can either have not started yet (pending), be active, 
       #    or have expired.
       #
       # If there is an active role, we are done.
       #
       # If there is more than one role which has not started yet, 
       #     choose the one which will start sooner
       # If there is one role which has not started yet, return it.
       #
       # If there is more than one expired role, choose the one which ended last.
       # If there is a role which has expired, return it.
       #
       foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
                           &homeserver($unam,$udom)))) {
           my ($key,$value)=split(/\=/,$_);
           $key=&unescape($key);
           next if ($key !~/^$courseid(?:\/)*(\w+)*\_st$/);
           my $section=$1;
           if ($key eq $courseid.'_st') { $section=''; }
           my ($dummy,$end,$start)=split(/\_/,&unescape($value));
           my $now=time;
           if (defined($end) && ($now > $end)) {
               $Expired{$end}=$section;
               next;
           }
           if (defined($start) && ($now < $start)) {
               $Pending{$start}=$section;
               next;
           }
           return $section;
       }
       #
       # Presumedly there will be few matching roles from the above
       # loop and the sorting time will be negligible.
       if (scalar(keys(%Pending))) {
           my ($time) = sort {$a <=> $b} keys(%Pending);
           return $Pending{$time};
       } 
       if (scalar(keys(%Expired))) {
           my @sorted = sort {$a <=> $b} keys(%Expired);
           my $time = pop(@sorted);
           return $Expired{$time};
       }
       return '-1';
   }
   
 sub usection {  sub usection {
     my ($udom,$unam,$courseid)=@_;      my ($udom,$unam,$courseid)=@_;
     $courseid=~s/\_/\//g;      $courseid=~s/\_/\//g;
Line 620  sub chatsend { Line 699  sub chatsend {
    &escape($newentry)),$chome);     &escape($newentry)),$chome);
 }  }
   
   # ------------------------------------------ Find current version of a resource
   
   sub getversion {
       my $fname=&clutter(shift);
       unless ($fname=~/^\/res\//) { return -1; }
       return &currentversion(&filelocation('',$fname));
   }
   
   sub currentversion {
       my $fname=shift;
       my $author=$fname;
       $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
       my ($udom,$uname)=split(/\//,$author);
       my $home=homeserver($uname,$udom);
       if ($home eq 'no_host') { 
           return -1; 
       }
       my $answer=reply("currentversion:$fname",$home);
       if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
    return -1;
       }
       return $answer;
   }
   
 # ----------------------------- Subscribe to a resource, return URL if possible  # ----------------------------- Subscribe to a resource, return URL if possible
   
 sub subscribe {  sub subscribe {
Line 628  sub subscribe { Line 731  sub subscribe {
     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;      $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
     my ($udom,$uname)=split(/\//,$author);      my ($udom,$uname)=split(/\//,$author);
     my $home=homeserver($uname,$udom);      my $home=homeserver($uname,$udom);
     if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) {       if ($home eq 'no_host') { 
         return 'not_found';           return 'not_found'; 
     }      }
     my $answer=reply("sub:$fname",$home);      my $answer=reply("sub:$fname",$home);
Line 659  sub repcopy { Line 762  sub repcopy {
     } elsif ($remoteurl eq 'directory') {      } elsif ($remoteurl eq 'directory') {
            return OK;             return OK;
     } else {      } else {
           my $author=$filename;
           $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
           my ($udom,$uname)=split(/\//,$author);
           my $home=homeserver($uname,$udom);
           unless ($home eq $perlvar{'lonHostID'}) {
            my @parts=split(/\//,$filename);             my @parts=split(/\//,$filename);
            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";             my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
            if ($path ne "$perlvar{'lonDocRoot'}/res") {             if ($path ne "$perlvar{'lonDocRoot'}/res") {
Line 694  sub repcopy { Line 802  sub repcopy {
                rename($transname,$filename);                 rename($transname,$filename);
                return OK;                 return OK;
            }             }
          }
     }      }
 }  }
   
Line 761  sub userfileupload { Line 870  sub userfileupload {
         $docudom=$ENV{'user.domain'};          $docudom=$ENV{'user.domain'};
         $docuhome=$ENV{'user.home'};          $docuhome=$ENV{'user.home'};
     }      }
       return 
           &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
   }
   
   sub finishuserfileupload {
       my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;
     my $path=$docudom.'/'.$docuname.'/';      my $path=$docudom.'/'.$docuname.'/';
     my $filepath=$perlvar{'lonDocRoot'};      my $filepath=$perlvar{'lonDocRoot'};
     my @parts=split(/\//,$filepath.'/userfiles/'.$path);      my @parts=split(/\//,$filepath.'/userfiles/'.$path);
Line 778  sub userfileupload { Line 893  sub userfileupload {
     }      }
 # Notify homeserver to grep it  # Notify homeserver to grep it
 #  #
     if       
 (&reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome) eq 'ok')       my $fetchresult= 
     {   &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome);
       if ($fetchresult eq 'ok') {
 #  #
 # Return the URL to it  # Return the URL to it
         return '/uploaded/'.$path.$fname;          return '/uploaded/'.$path.$fname;
     } else {      } else {
           &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$fname.
            ' to host '.$docuhome.': '.$fetchresult);
         return '/adm/notfound.html';          return '/adm/notfound.html';
     }          }    
 }  }
Line 865  sub countacc { Line 983  sub countacc {
     my $url=&declutter(shift);      my $url=&declutter(shift);
     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';
     if (defined($accesshash{$key})) {      if (defined($accesshash{$key})) {
  $accesshash{$key}++;   $accesshash{$key}++;
     } else {      } else {
Line 985  sub devalidate { Line 1103  sub devalidate {
     if ($cid) {      if ($cid) {
  my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':';   my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':';
         my $status=          my $status=
     &del('nohist_calculatedsheet',      &del('nohist_calculatedsheets',
  [$key.'studentcalc'],   [$key.'studentcalc'],
  $ENV{'course.'.$cid.'.domain'},   $ENV{'course.'.$cid.'.domain'},
  $ENV{'course.'.$cid.'.num'})   $ENV{'course.'.$cid.'.num'})
Line 1435  sub coursedescription { Line 1553  sub coursedescription {
            while (my ($name,$value) = each %returnhash) {             while (my ($name,$value) = each %returnhash) {
                $envhash{'course.'.$normalid.'.'.$name}=$value;                 $envhash{'course.'.$normalid.'.'.$name}=$value;
            }             }
            $returnhash{'url'}='/res/'.declutter($returnhash{'url'});             $returnhash{'url'}=&clutter($returnhash{'url'});
            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.             $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
        $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;         $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
            $envhash{'course.'.$normalid.'.last_cache'}=time;             $envhash{'course.'.$normalid.'.last_cache'}=time;
Line 1563  sub get { Line 1681  sub get {
   
    my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);     my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
    my @pairs=split(/\&/,$rep);     my @pairs=split(/\&/,$rep);
      if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
        return @pairs;
      }
    my %returnhash=();     my %returnhash=();
    my $i=0;     my $i=0;
    foreach (@$storearr) {     foreach (@$storearr) {
Line 1681  sub allowed { Line 1802  sub allowed {
   
     if ($priv eq 'bre') {      if ($priv eq 'bre') {
         my $copyright=&metadata($uri,'copyright');          my $copyright=&metadata($uri,'copyright');
  if ($copyright eq 'public') { return 'F'; }   if (($copyright eq 'public') && (!$ENV{'request.course.id'})) { 
              return 'F'; 
           }
         if ($copyright eq 'priv') {          if ($copyright eq 'priv') {
             $uri=~/([^\/]+)\/([^\/]+)\//;              $uri=~/([^\/]+)\/([^\/]+)\//;
     unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) {      unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) {
Line 1953  sub is_on_map { Line 2076  sub is_on_map {
     my @uriparts=split(/\//,$uri);      my @uriparts=split(/\//,$uri);
     my $filename=$uriparts[$#uriparts];      my $filename=$uriparts[$#uriparts];
     my $pathname=$uri;      my $pathname=$uri;
     $pathname=~s/\/$filename$//;      $pathname=~s|/\Q$filename\E$||;
       #Trying to find the conditional for the file
     my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~      my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
        /\&$filename\:([\d\|]+)\&/);         /\&\Q$filename\E\:([\d\|]+)\&/);
     if ($match) {      if ($match) {
        return (1,$1);   return (1,$1);
    } else {      } else {
        return (0,0);   return (0,0);
    }      }
 }  }
   
 # ----------------------------------------------------------------- Define Role  # ----------------------------------------------------------------- Define Role
Line 2137  sub modifyuserauth { Line 2261  sub modifyuserauth {
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom);
     unless (&allowed('mau',$udom)) { return 'refused'; }      unless (&allowed('mau',$udom)) { return 'refused'; }
     &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.      &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
              $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});                 $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}.
                ' in domain '.$ENV{'request.role.domain'});  
     my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.      my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
      &escape($upass),$uhome);       &escape($upass),$uhome);
     &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},      &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},
Line 2168  sub modifyuser { Line 2293  sub modifyuser {
      $last.', '.$gene.'(forceid: '.$forceid.')'.       $last.', '.$gene.'(forceid: '.$forceid.')'.
              (defined($desiredhome) ? ' desiredhome = '.$desiredhome :               (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
                                      ' desiredhome not specified').                                        ' desiredhome not specified'). 
              ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});               ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}.
                ' in domain '.$ENV{'request.role.domain'});
     my $uhome=&homeserver($uname,$udom,'true');      my $uhome=&homeserver($uname,$udom,'true');
 # ----------------------------------------------------------------- Create User  # ----------------------------------------------------------------- Create User
     if (($uhome eq 'no_host') && ($umode) && ($upass)) {      if (($uhome eq 'no_host') && ($umode) && ($upass)) {
Line 2249  sub modifystudent { Line 2375  sub modifystudent {
  ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,   ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
          $desiredhome);           $desiredhome);
     unless ($reply eq 'ok') { return $reply; }      unless ($reply eq 'ok') { return $reply; }
       # This will cause &modify_student_enrollment to get the uid from the
       # students environment
       $uid = undef if (!$forceid);
       $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,
                                           $last,$gene,$usec,$end,$start);
       return $reply;
   }
   
   sub modify_student_enrollment {
       my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start) = @_;
       # Get the course id from the environment
       my $cid='';
       unless ($cid=$ENV{'request.course.id'}) {
    return 'not_in_class';
       }
       # 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';
     }      }
 # -------------------------------------------------- Add student to course list      #
     $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.      # Get student data if we were not given enough information
       if (!defined($first)  || $first  eq '' || 
           !defined($last)   || $last   eq '' || 
           !defined($uid)    || $uid    eq '' || 
           !defined($middle) || $middle eq '' || 
           !defined($gene)   || $gene   eq '') {
           # They did not supply us with enough data to enroll the student, so
           # we need to pick up more information.
           my %tmp = &get('environment',
                          ['firstname','middlename','lastname', 'generation','id']
                          ,$udom,$uname);
   
           foreach (keys(%tmp)) {
               &logthis("key $_ = ".$tmp{$_});
           }
           $first  = $tmp{'firstname'}  if (!defined($first)  || $first  eq '');
           $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');
           $last   = $tmp{'lastname'}   if (!defined($last)   || $last eq '');
           $gene   = $tmp{'generation'} if (!defined($gene)   || $gene eq '');
           $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');
       }
       my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,
                                                              $first,$middle);
       my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
               $ENV{'course.'.$cid.'.num'}.':classlist:'.                $ENV{'course.'.$cid.'.num'}.':classlist:'.
                       &escape($uname.':'.$udom).'='.                        &escape($uname.':'.$udom).'='.
                       &escape($end.':'.$start),                        &escape(join(':',$end,$start,$uid,$usec,$fullname)),
               $ENV{'course.'.$cid.'.home'});                $ENV{'course.'.$cid.'.home'});
     unless (($reply eq 'ok') || ($reply eq 'delayed')) {      unless (($reply eq 'ok') || ($reply eq 'delayed')) {
  return 'error: '.$reply;   return 'error: '.$reply;
     }      }
 # ---------------------------------------------------- Add student role to user      # Add student role to user
     my $uurl='/'.$cid;      my $uurl='/'.$cid;
     $uurl=~s/\_/\//g;      $uurl=~s/\_/\//g;
     if ($usec) {      if ($usec) {
Line 2293  sub writecoursepref { Line 2458  sub writecoursepref {
 # ---------------------------------------------------------- Make/modify course  # ---------------------------------------------------------- Make/modify course
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url,$course_server)=@_;      my ($udom,$description,$url,$course_server,$nonstandard)=@_;
     $url=&declutter($url);      $url=&declutter($url);
     my $cid='';      my $cid='';
     unless (&allowed('ccc',$udom)) {      unless (&allowed('ccc',$udom)) {
Line 2325  sub createcourse { Line 2490  sub createcourse {
     if (($uhome eq '') || ($uhome eq 'no_host')) {       if (($uhome eq '') || ($uhome eq 'no_host')) { 
  return 'error: no such course';   return 'error: no such course';
     }      }
   # ----------------------------------------------------------------- Course made
       my $topurl=$url;
       unless ($nonstandard) {
   # ------------------------------------------ For standard courses, make top url
           my $mapurl=&clutter($url);
           if ($mapurl eq '/res/') { $mapurl=''; }
           $ENV{'form.initmap'}=(<<ENDINITMAP);
   <map>
   <resource id="1" type="start"></resource>
   <resource id="2" src="$mapurl"></resource>
   <resource id="3" type="finish"></resource>
   <link index="1" from="1" to="2"></link>
   <link index="2" from="2" to="3"></link>
   </map>
   ENDINITMAP
           $topurl=&declutter(
           &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence')
                             );
       }
   # ----------------------------------------------------------- Write preferences
     &writecoursepref($udom.'_'.$uname,      &writecoursepref($udom.'_'.$uname,
                      ('description' => $description,                       ('description' => $description,
                       'url'         => $url));                        'url'         => $topurl));
     return '/'.$udom.'/'.$uname;      return '/'.$udom.'/'.$uname;
 }  }
   
Line 2428  sub dirlist { Line 2613  sub dirlist {
     }      }
 }  }
   
   # --------------------------------------------- GetFileTimestamp
   # This function utilizes dirlist and returns the date stamp for
   # when it was last modified.  It will also return an error of -1
   # if an error occurs
   
   sub GetFileTimestamp {
       my ($studentDomain,$studentName,$filename,$root)=@_;
       $studentDomain=~s/\W//g;
       $studentName=~s/\W//g;
       my $subdir=$studentName.'__';
       $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
       my $proname="$studentDomain/$subdir/$studentName";
       $proname .= '/'.$filename;
       my @dir = &Apache::lonnet::dirlist($proname, $studentDomain, $studentName,
                                          $root);
       my $fileStat = $dir[0];
       my @stats = split('&', $fileStat);
       if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
           return $stats[9];
       } else {
           return -1;
       }
   }
   
 # -------------------------------------------------------- Value of a Condition  # -------------------------------------------------------- Value of a Condition
   
 sub directcondval {  sub directcondval {
Line 2480  sub condval { Line 2689  sub condval {
     return $result;      return $result;
 }  }
   
   # ---------------------------------------------------- Devalidate courseresdata
   
   sub devalidatecourseresdata {
       my ($coursenum,$coursedomain)=@_;
       my $hashid=$coursenum.':'.$coursedomain;
       delete $courseresdatacache{$hashid.'.time'};
   }
   
 # --------------------------------------------------- Course Resourcedata Query  # --------------------------------------------------- Course Resourcedata Query
   
 sub courseresdata {  sub courseresdata {
Line 2501  sub courseresdata { Line 2718  sub courseresdata {
  }   }
     }      }
     foreach my $item (@which) {      foreach my $item (@which) {
  if ($courseresdatacache{$hashid}->{$item}) {   if (defined($courseresdatacache{$hashid}->{$item})) {
     return $courseresdatacache{$hashid}->{$item};      return $courseresdatacache{$hashid}->{$item};
  }   }
     }      }
     return '';      return undef;
 }  }
   
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
   
 sub EXT {  sub EXT {
     my ($varname,$symbparm,$udom,$uname)=@_;      my ($varname,$symbparm,$udom,$uname,)=@_;
   
     unless ($varname) { return ''; }      unless ($varname) { return ''; }
   
Line 2652  sub EXT { Line 2869  sub EXT {
   ($seclevelr,$seclevelm,$seclevel,    ($seclevelr,$seclevelm,$seclevel,
    $courselevelr,$courselevelm,     $courselevelr,$courselevelm,
    $courselevel));     $courselevel));
     if ($coursereply) { return $coursereply; }      if (defined($coursereply)) { return $coursereply; }
   
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
     my %parmhash=();      my %parmhash=();
Line 2668  sub EXT { Line 2885  sub EXT {
 # --------------------------------------------- last, look in resource metadata  # --------------------------------------------- last, look in resource metadata
   
  $spacequalifierrest=~s/\./\_/;   $spacequalifierrest=~s/\./\_/;
  my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest);   my $filename;
  if ($metadata) { return $metadata; }   if (!$symbparm) { $symbparm=&symbread(); }
  $metadata=&metadata($ENV{'request.filename'},   if ($symbparm) {
     'parameter_'.$spacequalifierrest);      $filename=(split(/\_\_\_/,$symbparm))[2];
  if ($metadata) { return $metadata; }   } else {
       $filename=$ENV{'request.filename'};
    }
    my $metadata=&metadata($filename,$spacequalifierrest);
    if (defined($metadata)) { return $metadata; }
    $metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
    if (defined($metadata)) { return $metadata; }
   
 # ------------------------------------------------------------------ Cascade up  # ------------------------------------------------------------------ Cascade up
  unless ($space eq '0') {   unless ($space eq '0') {
Line 2680  sub EXT { Line 2903  sub EXT {
     if ($id) {      if ($id) {
  my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,   my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
      $symbparm,$udom,$uname);       $symbparm,$udom,$uname);
  if ($partgeneral) { return $partgeneral; }   if (defined($partgeneral)) { return $partgeneral; }
     } else {      } else {
  my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,   my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
  $symbparm,$udom,$uname);   $symbparm,$udom,$uname);
  if ($resourcegeneral) { return $resourcegeneral; }   if (defined($resourcegeneral)) { return $resourcegeneral; }
     }      }
  }   }
   
Line 2713  sub metadata { Line 2936  sub metadata {
     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;      my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
   
     $uri=&declutter($uri);      $uri=&declutter($uri);
       # if it is a non metadata possible uri return quickly
       if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||
           ($uri =~ m|/$|) || ($uri =~ m|/.meta$|)) {
    return '';
       }
     my $filename=$uri;      my $filename=$uri;
     $uri=~s/\.meta$//;      $uri=~s/\.meta$//;
 #  #
Line 2870  sub metadata_generate_part0 { Line 3098  sub metadata_generate_part0 {
     }      }
 }  }
   
   # ------------------------------------------------- Get the title of a resource
   
   sub gettitle {
       my $urlsymb=shift;
       my $symb=&symbread($urlsymb);
       unless ($symb) {
    unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }
           return &metadata($urlsymb,'title'); 
       }
       if ($titlecache{$symb}) { return $titlecache{$symb}; }
       my ($map,$resid,$url)=split(/\_\_\_/,$symb);
       my $title='';
       my %bighash;
       if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                               &GDBM_READER(),0640)) {
           my $mapid=$bighash{'map_pc_'.&clutter($map)};
           $title=$bighash{'title_'.$mapid.'.'.$resid};
           untie %bighash;
       }
       if ($title) {
           $titlecache{$symb}=$title;
           return $title;
       } else {
    return &metadata($urlsymb,'title');
       }
   }
       
 # ------------------------------------------------- Update symbolic store links  # ------------------------------------------------- Update symbolic store links
   
 sub symblist {  sub symblist {
Line 2907  sub symbverify { Line 3162  sub symbverify {
     my $okay=0;      my $okay=0;
     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
         my $ids=$bighash{'ids_/res/'.$thisfn};          my $ids=$bighash{'ids_'.&clutter($thisfn)};
         unless ($ids) {           unless ($ids) { 
            $ids=$bighash{'ids_/'.$thisfn};             $ids=$bighash{'ids_/'.$thisfn};
         }          }
Line 2978  sub symbread { Line 3233  sub symbread {
            if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',             if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
 # ---------------------------------------------- Get ID(s) for current resource  # ---------------------------------------------- Get ID(s) for current resource
               my $ids=$bighash{'ids_/res/'.$thisfn};                my $ids=$bighash{'ids_'.&clutter($thisfn)};
               unless ($ids) {                 unless ($ids) { 
                  $ids=$bighash{'ids_/'.$thisfn};                   $ids=$bighash{'ids_/'.$thisfn};
               }                }
Line 3085  sub receipt { Line 3340  sub receipt {
 # ------------------------------------------------------------ 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 a -1
 sub getfile {  sub getfile {
   my $file=shift;   my $file=shift;
    if ($file=~/^\/*uploaded\//) { # user file
       my $ua=new LWP::UserAgent;
       my $request=new HTTP::Request('GET',&tokenwrapper($file));
       my $response=$ua->request($request);
       if ($response->is_success()) {
          return $response->content;
       } else { 
          return -1; 
       }
    } else { # normal file from res space
   &repcopy($file);    &repcopy($file);
   if (! -e $file ) { return -1; };    if (! -e $file ) { return -1; };
   my $fh=Apache::File->new($file);    my $fh=Apache::File->new($file);
   my $a='';    my $a='';
   while (<$fh>) { $a .=$_; }    while (<$fh>) { $a .=$_; }
   return $a    return $a;
    }
 }  }
   
 sub filelocation {  sub filelocation {
Line 3101  sub filelocation { Line 3367  sub filelocation {
   if ($file=~m:^/~:) { # is a contruction space reference    if ($file=~m:^/~:) { # is a contruction space reference
     $location = $file;      $location = $file;
     $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;      $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
     } elsif ($file=~/^\/*uploaded/) { # is an uploaded file
       $location=$file;
   } else {    } else {
     $file=~s/^$perlvar{'lonDocRoot'}//;      $file=~s/^$perlvar{'lonDocRoot'}//;
     $file=~s:^/*res::;      $file=~s:^/*res::;
Line 3138  sub declutter { Line 3406  sub declutter {
     return $thisfn;      return $thisfn;
 }  }
   
   # ------------------------------------------------------------- Clutter up URLs
   
   sub clutter {
       my $thisfn='/'.&declutter(shift);
       unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) { 
          $thisfn='/res'.$thisfn; 
       }
       return $thisfn;
   }
   
 # -------------------------------------------------------- Escape Special Chars  # -------------------------------------------------------- Escape Special Chars
   
 sub escape {  sub escape {
Line 3199  BEGIN { Line 3477  BEGIN {
  $hostname{$id}=$name;   $hostname{$id}=$name;
  $hostdom{$id}=$domain;   $hostdom{$id}=$domain;
  $hostip{$id}=$ip;   $hostip{$id}=$ip;
    $iphost{$ip}=$id;
  if ($domdescr) { $domaindescription{$domain}=$domdescr; }   if ($domdescr) { $domaindescription{$domain}=$domdescr; }
  if ($role eq 'library') { $libserv{$id}=$name; }   if ($role eq 'library') { $libserv{$id}=$name; }
        } else {         } else {
Line 3215  BEGIN { Line 3494  BEGIN {
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
        chomp($configline);         chomp($configline);
        if (($configline) && ($configline ne $perlvar{'lonHostID'})) {         if ($configline) {
           $spareid{$configline}=1;            $spareid{$configline}=1;
        }         }
     }      }
Line 3263  BEGIN { Line 3542  BEGIN {
   
 %metacache=();  %metacache=();
   
 $processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'};  $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
 $dumpcount=0;  $dumpcount=0;
   
 &logtouch();  &logtouch();
Line 3479  modify user Line 3758  modify user
   
 =item *  =item *
   
 modifystudent($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,$end,$start) : modify student  modifystudent
   
   modify a students enrollment and identification information.
   The course id is resolved based on the current users environment.  
   This means the envoking user must be a course coordinator or otherwise
   associated with a course.
   
   This call is essentially a wrapper for lonnet::modifyuser and
   lonnet::modify_student_enrollment
   
   Inputs: 
   
   =over 4
   
   =item B<$udom> Students loncapa domain
   
   =item B<$uname> Students loncapa login name
   
   =item B<$uid> Students id/student number
   
   =item B<$umode> Students authentication mode
   
   =item B<$upass> Students password
   
   =item B<$first> Students first name
   
   =item B<$middle> Students middle name
   
   =item B<$last> Students last name
   
   =item B<$gene> Students generation
   
   =item B<$usec> Students section in course
   
   =item B<$end> Unix time of the roles expiration
   
   =item B<$start> Unix time of the roles start date
   
   =item B<$forceid> If defined, allow $uid to be changed
   
   =item B<$desiredhome> server to use as home server for student
   
   =back
   
   =item *
   
   modify_student_enrollment
   
   Change a students enrollment status in a class.  The environment variable
   'role.request.course' must be defined for this function to proceed.
   
   Inputs:
   
   =over 4
   
   =item $udom, students domain
   
   =item $uname, students name
   
   =item $uid, students user id
   
   =item $first, students first name
   
   =item $middle
   
   =item $last
   
   =item $gene
   
   =item $usec
   
   =item $end
   
   =item $start
   
   =back
   
   
 =item *  =item *
   
Removed from v.1.267.4.3  
changed lines
  Added in v.1.301

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