[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.286 and 1.320

version 1.286, 2002/09/24 18:25:45 version 1.320, 2003/01/28 00:09:57
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;
 use GDBM_File;  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 140  sub reply { Line 143  sub reply {
     unless (defined($hostname{$server})) { return 'no_such_host'; }      unless (defined($hostname{$server})) { return 'no_such_host'; }
     my $answer=subreply($cmd,$server);      my $answer=subreply($cmd,$server);
     if ($answer eq 'con_lost') {      if ($answer eq 'con_lost') {
        #sleep 5;           #sleep 5; 
        #$answer=subreply($cmd,$server);          #$answer=subreply($cmd,$server);
        #if ($answer eq 'con_lost') {          #if ($answer eq 'con_lost') {
  #   &logthis("Second attempt con_lost on $server");   #   &logthis("Second attempt con_lost on $server");
         #   my $peerfile="$perlvar{'lonSockDir'}/$server";          #   my $peerfile="$perlvar{'lonSockDir'}/$server";
         #   my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",          #   my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
Line 213  sub critical { Line 216  sub critical {
             $middlename=substr($middlename,0,16);              $middlename=substr($middlename,0,16);
             $middlename=~s/\W//g;              $middlename=~s/\W//g;
             my $dfilename=              my $dfilename=
              "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server";        "$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server";
               $dumpcount++;
             {              {
              my $dfh;               my $dfh;
              if ($dfh=Apache::File->new(">$dfilename")) {               if ($dfh=Apache::File->new(">$dfilename")) {
Line 591  sub idput { Line 595  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 644  sub chatsend { Line 701  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 {
     my $fname=shift;      my $fname=shift;
       if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }
     my $author=$fname;      my $author=$fname;
     $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 683  sub repcopy { Line 765  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 718  sub repcopy { Line 805  sub repcopy {
                rename($transname,$filename);                 rename($transname,$filename);
                return OK;                 return OK;
            }             }
          }
     }      }
 }  }
   
Line 755  sub tokenwrapper { Line 843  sub tokenwrapper {
     if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {      if ($uri=~/^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.
                                  '&tokenissued='.$perlvar{'lonHostID'};
     } else {      } else {
  return '/adm/notfound.html';   return '/adm/notfound.html';
     }      }
Line 768  sub tokenwrapper { Line 857  sub tokenwrapper {
 sub userfileupload {  sub userfileupload {
     my ($formname,$coursedoc)=@_;      my ($formname,$coursedoc)=@_;
     my $fname=$ENV{'form.'.$formname.'.filename'};      my $fname=$ENV{'form.'.$formname.'.filename'};
   # Replace Windows backslashes by forward slashes
     $fname=~s/\\/\//g;      $fname=~s/\\/\//g;
   # Get rid of everything but the actual filename
     $fname=~s/^.*\/([^\/]+)$/$1/;      $fname=~s/^.*\/([^\/]+)$/$1/;
   # Replace spaces by underscores
       $fname=~s/\s+/\_/g;
   # Replace all other weird characters by nothing
       $fname=~s/[^\w\.\-]//g;
   # See if there is anything left
     unless ($fname) { return 'error: no uploaded file'; }      unless ($fname) { return 'error: no uploaded file'; }
     chop($ENV{'form.'.$formname});      chop($ENV{'form.'.$formname});
 # Create the directory if not present  # Create the directory if not present
Line 808  sub finishuserfileupload { Line 904  sub finishuserfileupload {
     }      }
 # 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 1015  sub devalidate { Line 1114  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 1454  sub coursedescription { Line 1553  sub coursedescription {
     $courseid=~s/\_/\//g;      $courseid=~s/\_/\//g;
     my ($cdomain,$cnum)=split(/\//,$courseid);      my ($cdomain,$cnum)=split(/\//,$courseid);
     my $chome=&homeserver($cnum,$cdomain);      my $chome=&homeserver($cnum,$cdomain);
       my $normalid=$cdomain.'_'.$cnum;
       # need to always cache even if we get errors otherwise we keep 
       # trying and trying and trying to get the course description.
       my %envhash=();
       my %returnhash=();
       $envhash{'course.'.$normalid.'.last_cache'}=time;
     if ($chome ne 'no_host') {      if ($chome ne 'no_host') {
        my %returnhash=&dump('environment',$cdomain,$cnum);         %returnhash=&dump('environment',$cdomain,$cnum);
        if (!exists($returnhash{'con_lost'})) {         if (!exists($returnhash{'con_lost'})) {
            my $normalid=$cdomain.'_'.$cnum;  
            my %envhash=();  
            $returnhash{'home'}= $chome;             $returnhash{'home'}= $chome;
    $returnhash{'domain'} = $cdomain;     $returnhash{'domain'} = $cdomain;
    $returnhash{'num'} = $cnum;     $returnhash{'num'} = $cnum;
Line 1468  sub coursedescription { Line 1571  sub coursedescription {
            $returnhash{'url'}=&clutter($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.'.home'}=$chome;             $envhash{'course.'.$normalid.'.home'}=$chome;
            $envhash{'course.'.$normalid.'.domain'}=$cdomain;             $envhash{'course.'.$normalid.'.domain'}=$cdomain;
            $envhash{'course.'.$normalid.'.num'}=$cnum;             $envhash{'course.'.$normalid.'.num'}=$cnum;
            &appenv(%envhash);  
            return %returnhash;  
        }         }
     }      }
     return ();      &appenv(%envhash);
       return %returnhash;
 }  }
   
 # -------------------------------------------------------- Get user privileges  # -------------------------------------------------------- Get user privileges
Line 1643  sub dump { Line 1744  sub dump {
    return %returnhash;     return %returnhash;
 }  }
   
   # --------------------------------------------------------------- currentdump
   sub currentdump {
      my ($namespace,$udomain,$uname)=@_;
      if (!$udomain) { $udomain = $ENV{'user.domain'}; }
      if (!$uname)   { $uname   = $ENV{'user.name'};   }
      my $uhome = &homeserver($uname,$udomain);
      my $rep=reply("currentdump:$udomain:$uname:$namespace",$uhome);
      return if ($rep =~ /^(error:|no_such_host)/);
      #
      my %returnhash=();
      #
      if ($rep eq "unknown_cmd") { 
          # an old lond will not know currentdump
          # Do a dump and make it look like a currentdump
          my @tmp = &dump($namespace,$udomain,$uname,'.');
          return if ($tmp[0] =~ /^(error:|no_such_host)/);
          my %hash = @tmp;
          @tmp=();
          # Code ripped from lond, essentially.  The only difference
          # here is the unescaping done by lonnet::dump().  Conceivably
          # we might run in to problems with parameter names =~ /^v\./
          while (my ($key,$value) = each(%hash)) {
              my ($v,$symb,$param) = split(/:/,$key);
              next if ($v eq 'version' || $symb eq 'keys');
              next if (exists($returnhash{$symb}) &&
                       exists($returnhash{$symb}->{$param}) &&
                       $returnhash{$symb}->{'v.'.$param} > $v);
              $returnhash{$symb}->{$param}=$value;
              $returnhash{$symb}->{'v.'.$param}=$v;
          }
          #
          # Remove all of the keys in the hashes which keep track of
          # the version of the parameter.
          while (my ($symb,$param_hash) = each(%returnhash)) {
              # use a foreach because we are going to delete from the hash.
              foreach my $key (keys(%$param_hash)) {
                  delete($param_hash->{$key}) if ($key =~ /^v\./);
              }
          }
      } else {
          my @pairs=split(/\&/,$rep);
          foreach (@pairs) {
              my ($key,$value)=split(/=/,$_);
              my ($symb,$param) = split(/:/,$key);
              $returnhash{&unescape($symb)}->{&unescape($param)} = 
                                                             &unescape($value);
          }
      }
      return %returnhash;
   }
   
 # --------------------------------------------------------------- put interface  # --------------------------------------------------------------- put interface
   
 sub put {  sub put {
Line 1714  sub allowed { Line 1866  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 1768  sub allowed { Line 1922  sub allowed {
        $thisallowed.=$1;         $thisallowed.=$1;
     }      }
   
   # URI is an uploaded document for this course
   
       if (($priv eq 'bre') && 
           ($uri=~/^uploaded\/$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}\/$ENV{'course.'.$ENV{'request.course.id'}.'.num'}/)) {
           return 'F';
       }
 # Full access at system, domain or course-wide level? Exit.  # Full access at system, domain or course-wide level? Exit.
   
     if ($thisallowed=~/F/) {      if ($thisallowed=~/F/) {
Line 1986  sub is_on_map { Line 2146  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 2253  sub modifyuser { Line 2414  sub modifyuser {
        }         }
     }      }
 # -------------------------------------------------------------- Add names, etc  # -------------------------------------------------------------- Add names, etc
     my %names=&get('environment',      my @tmp=&get('environment',
    ['firstname','middlename','lastname','generation'],     ['firstname','middlename','lastname','generation'],
    $udom,$uname);     $udom,$uname);
     if ($names{'firstname'} =~ m/^error:.*/) { %names=(); }      my %names;
       if ($tmp[0] =~ m/^error:.*/) { 
           %names=(); 
       } else {
           %names = @tmp;
       }
     if ($first)  { $names{'firstname'}  = $first; }      if ($first)  { $names{'firstname'}  = $first; }
     if ($middle) { $names{'middlename'} = $middle; }      if ($middle) { $names{'middlename'} = $middle; }
     if ($last)   { $names{'lastname'}   = $last; }      if ($last)   { $names{'lastname'}   = $last; }
Line 2284  sub modifystudent { Line 2450  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 2585  sub courseresdata { Line 2790  sub courseresdata {
  if ($tmp !~ /^(con_lost|error|no_such_host)/i) {   if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
     $courseresdatacache{$hashid.'.time'}=time;      $courseresdatacache{$hashid.'.time'}=time;
     $courseresdatacache{$hashid}=\%dumpreply;      $courseresdatacache{$hashid}=\%dumpreply;
    } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
       return $tmp;
  }   }
     }      }
     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
Line 2610  sub EXT { Line 2817  sub EXT {
     } else {      } else {
  $courseid=$ENV{'request.course.id'};   $courseid=$ENV{'request.course.id'};
     }      }
   
     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);      my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
     my $rest;      my $rest;
     if ($therest[0]) {      if (defined($therest[0])) {
        $rest=join('.',@therest);         $rest=join('.',@therest);
     } else {      } else {
        $rest='';         $rest='';
     }      }
   
     my $qualifierrest=$qualifier;      my $qualifierrest=$qualifier;
     if ($rest) { $qualifierrest.='.'.$rest; }      if ($rest) { $qualifierrest.='.'.$rest; }
     my $spacequalifierrest=$space;      my $spacequalifierrest=$space;
Line 2711  sub EXT { Line 2918  sub EXT {
     my $courselevelm=$courseid.'.'.$mapparm;      my $courselevelm=$courseid.'.'.$mapparm;
   
 # ----------------------------------------------------------- first, check user  # ----------------------------------------------------------- first, check user
     my %resourcedata=&get('resourcedata',      #most student don't have any data set, check if there is some data
   [$courselevelr,$courselevelm,$courselevel],              #every thirty minutes
  $udom,$uname);      if (!
     if (($resourcedata{$courselevelr}!~/^error\:/) &&   (exists($ENV{'cache.studentresdata'})
  ($resourcedata{$courselevelr}!~/^con_lost/)) {      && (($ENV{'cache.studentresdata'}+1800) > time))) {
    my %resourcedata=&get('resourcedata',
  if ($resourcedata{$courselevelr}) {        [$courselevelr,$courselevelm,$courselevel],
     return $resourcedata{$courselevelr}; }        $udom,$uname);
  if ($resourcedata{$courselevelm}) {   my ($tmp)=keys(%resourcedata);
     return $resourcedata{$courselevelm}; }   if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
  if ($resourcedata{$courselevel}) {      if ($resourcedata{$courselevelr}) {
     return $resourcedata{$courselevel}; }   return $resourcedata{$courselevelr}; }
     } else {      if ($resourcedata{$courselevelm}) {
  if ($resourcedata{$courselevelr}!~/No such file/) {   return $resourcedata{$courselevelm}; }
     &logthis("<font color=blue>WARNING:".      if ($resourcedata{$courselevel}) {
      " Trying to get resource data for ".   return $resourcedata{$courselevel}; }
      $uname." at ".$udom.": ".   } else {
      $resourcedata{$courselevelr}."</font>");      if ($tmp!~/No such file/) {
    &logthis("<font color=blue>WARNING:".
    " Trying to get resource data for ".
    $uname." at ".$udom.": ".
    $tmp."</font>");
       } elsif ($tmp=~/error:No such file/) {
    $ENV{'cache.studentresdata'}=time;
    &appenv(('cache.studentresdata'=>
    $ENV{'cache.studentresdata'}));
       } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
    return $tmp;
       }
  }   }
     }      }
   
Line 2739  sub EXT { Line 2957  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 2763  sub EXT { Line 2981  sub EXT {
     $filename=$ENV{'request.filename'};      $filename=$ENV{'request.filename'};
  }   }
  my $metadata=&metadata($filename,$spacequalifierrest);   my $metadata=&metadata($filename,$spacequalifierrest);
  if ($metadata) { return $metadata; }   if (defined($metadata)) { return $metadata; }
  $metadata=&metadata($filename,'parameter_'.$spacequalifierrest);   $metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
  if ($metadata) { return $metadata; }   if (defined($metadata)) { return $metadata; }
   
 # ------------------------------------------------------------------ Cascade up  # ------------------------------------------------------------------ Cascade up
  unless ($space eq '0') {   unless ($space eq '0') {
Line 2773  sub EXT { Line 2991  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 2806  sub metadata { Line 3024  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 2963  sub metadata_generate_part0 { Line 3186  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 3309  BEGIN { Line 3559  BEGIN {
     my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");      my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
          next if ($configline =~ /^(\#|\s*$)/);
        chomp($configline);         chomp($configline);
        my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline);         my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline);
        if ($id && $domain && $role && $name && $ip) {         if ($id && $domain && $role && $name && $ip) {
  $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 3602  The course id is resolved based on the c Line 3854  The course id is resolved based on the c
 This means the envoking user must be a course coordinator or otherwise  This means the envoking user must be a course coordinator or otherwise
 associated with a course.  associated with a course.
   
 This call is essentially a wrapper for lonnet::modifyuser  This call is essentially a wrapper for lonnet::modifyuser and
   lonnet::modify_student_enrollment
   
 Inputs:   Inputs: 
   
Line 3640  Inputs: Line 3893  Inputs:
   
 =item *  =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 *
   
 assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign  assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign
 custom role; give a custom role to a user for the level given by URL.  Specify  custom role; give a custom role to a user for the level given by URL.  Specify
 name and domain of role author, and role name  name and domain of role author, and role name
Removed from v.1.286  
changed lines
  Added in v.1.320

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