[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.370 and 1.387

version 1.370, 2003/05/08 21:50:54 version 1.387, 2003/07/05 10:07:11
Line 243  sub critical { Line 243  sub critical {
     }      }
     return $answer;      return $answer;
 }  }
    
   # ------------------------------------------- Transfer profile into environment
   
   sub transfer_profile_to_env {
       my ($lonidsdir,$handle)=@_;
       my @profile;
       {
    my $idf=Apache::File->new("$lonidsdir/$handle.id");
    flock($idf,LOCK_SH);
    @profile=<$idf>;
    $idf->close();
       }
       my $envi;
       for ($envi=0;$envi<=$#profile;$envi++) {
    chomp($profile[$envi]);
    my ($envname,$envvalue)=split(/=/,$profile[$envi]);
    $ENV{$envname} = $envvalue;
       }
       $ENV{'user.environment'} = "$lonidsdir/$handle.id";
   }
   
 # ---------------------------------------------------------- Append Environment  # ---------------------------------------------------------- Append Environment
   
Line 358  sub userload { Line 378  sub userload {
  while ($filename=readdir(LONIDS)) {   while ($filename=readdir(LONIDS)) {
     if ($filename eq '.' || $filename eq '..') {next;}      if ($filename eq '.' || $filename eq '..') {next;}
     my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8];      my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8];
     if ($curtime-$atime < 3600) { $num_users++; }      if ($curtime-$atime < 3600) { $numusers++; }
  }   }
  closedir(LONIDS);   closedir(LONIDS);
     }      }
     my $userloadpercent=0;      my $userloadpercent=0;
     my $maxuserload=$perlvar{'lonUserLoadLim'};      my $maxuserload=$perlvar{'lonUserLoadLim'};
     if ($maxuserload) {      if ($maxuserload) {
  $userloadpercent=100*$num_users/$maxuserload;   $userloadpercent=100*$numusers/$maxuserload;
     }      }
       $userloadpercent=sprintf("%.2f",$userloadpercent);
     return $userloadpercent;      return $userloadpercent;
 }  }
   
Line 961  sub repcopy { Line 982  sub repcopy {
   
 # ------------------------------------------------ Get server side include body  # ------------------------------------------------ Get server side include body
 sub ssi_body {  sub ssi_body {
     my $filelink=shift;      my ($filelink,%form)=@_;
     my $output=($filelink=~/^http\:/?&externalssi($filelink):      my $output=($filelink=~/^http\:/?&externalssi($filelink):
                                      &ssi($filelink));                                       &ssi($filelink,%form));
     $output=~s/^.*\<body[^\>]*\>//si;      $output=~s/^.*\<body[^\>]*\>//si;
     $output=~s/\<\/body\s*\>.*$//si;      $output=~s/\<\/body\s*\>.*$//si;
     $output=~      $output=~
Line 1259  sub get_course_adv_roles { Line 1280  sub get_course_adv_roles {
         } else {          } else {
             $returnhash{$key}=$username.':'.$domain;              $returnhash{$key}=$username.':'.$domain;
         }          }
     }       }
     return sort %returnhash;      return %returnhash;
 }  }
   
 # ---------------------------------------------------------- Course ID routines  # ---------------------------------------------------------- Course ID routines
Line 1622  sub tmpreset { Line 1643  sub tmpreset {
   my ($symb,$namespace,$domain,$stuname) = @_;    my ($symb,$namespace,$domain,$stuname) = @_;
   if (!$symb) {    if (!$symb) {
     $symb=&symbread();      $symb=&symbread();
     if (!$symb) { $symb= $ENV{'REQUEST_URI'}; }      if (!$symb) { $symb= $ENV{'request.url'}; }
   }    }
   $symb=escape($symb);    $symb=escape($symb);
   
Line 2640  sub assignrole { Line 2661  sub assignrole {
     } else {      } else {
         my $cwosec=$url;          my $cwosec=$url;
         $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;          $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
         unless (&allowed('c'.$role,$cwosec)) {           unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { 
            &logthis('Refused assignrole: '.             &logthis('Refused assignrole: '.
              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.               $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
     $ENV{'user.name'}.' at '.$ENV{'user.domain'});      $ENV{'user.name'}.' at '.$ENV{'user.domain'});
Line 2660  sub assignrole { Line 2681  sub assignrole {
     }      }
 # actually delete  # actually delete
     if ($deleteflag) {      if ($deleteflag) {
  if (&allowed('dro',$udom)) {   if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
 # modify command to delete the role  # modify command to delete the role
            $command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:".             $command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:".
                 "$udom:$uname:$url".'_'."$mrole";                  "$udom:$uname:$url".'_'."$mrole";
      &logthis("$ENV{'user.name'} at $ENV{'user.domain'} deletes $mrole in $url for $uname at $udom"); 
 # set start and finish to negative values for userrolelog  # set start and finish to negative values for userrolelog
            $start=-1;             $start=-1;
            $end=-1;             $end=-1;
Line 2710  sub modifyuser { Line 2732  sub modifyuser {
     my ($udom,    $uname, $uid,      my ($udom,    $uname, $uid,
         $umode,   $upass, $first,          $umode,   $upass, $first,
         $middle,  $last,  $gene,          $middle,  $last,  $gene,
         $forceid, $desiredhome)=@_;          $forceid, $desiredhome, $email)=@_;
     $udom=~s/\W//g;      $udom=~s/\W//g;
     $uname=~s/\W//g;      $uname=~s/\W//g;
     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
Line 2752  sub modifyuser { Line 2774  sub modifyuser {
         }             }   
         $uhome=&homeserver($uname,$udom,'true');          $uhome=&homeserver($uname,$udom,'true');
         if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {          if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
     return 'error: verify home';      return 'error: unable verify users home machine.';
         }          }
     }   # End of creation of new user      }   # End of creation of new user
 # ---------------------------------------------------------------------- Add ID  # ---------------------------------------------------------------------- Add ID
Line 2762  sub modifyuser { Line 2784  sub modifyuser {
        if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)          if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) 
          && (!$forceid)) {           && (!$forceid)) {
   unless ($uid eq $uidhash{$uname}) {    unless ($uid eq $uidhash{$uname}) {
       return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid;        return 'error: user id "'.$uid.'" does not match '.
                     'current user id "'.$uidhash{$uname}.'".';
           }            }
        } else {         } else {
   &idput($udom,($uname => $uid));    &idput($udom,($uname => $uid));
Line 2778  sub modifyuser { Line 2801  sub modifyuser {
     } else {      } else {
         %names = @tmp;          %names = @tmp;
     }      }
     if ($first)  { $names{'firstname'}  = $first; }  
     if ($middle) { $names{'middlename'} = $middle; }      if (defined($first))  { $names{'firstname'}  = $first; }
     if ($last)   { $names{'lastname'}   = $last; }      if (defined($middle)) { $names{'middlename'} = $middle; }
     if ($gene)   { $names{'generation'} = $gene; }      if (defined($last))   { $names{'lastname'}   = $last; }
       if (defined($gene))   { $names{'generation'} = $gene; }
       if (defined($email))  { $names{'notification'} = $email;
                               $names{'critnotification'} = $email; }
   
     my $reply = &put('environment', \%names, $udom,$uname);      my $reply = &put('environment', \%names, $udom,$uname);
     if ($reply ne 'ok') { return 'error: '.$reply; }      if ($reply ne 'ok') { return 'error: '.$reply; }
     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
Line 2795  sub modifyuser { Line 2822  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)=@_;          $end,$start,$forceid,$desiredhome,$email)=@_;
     my $cid='';      my $cid='';
     unless ($cid=$ENV{'request.course.id'}) {      unless ($cid=$ENV{'request.course.id'}) {
  return 'not_in_class';   return 'not_in_class';
Line 2803  sub modifystudent { Line 2830  sub modifystudent {
 # --------------------------------------------------------------- Make the user  # --------------------------------------------------------------- Make the user
     my $reply=&modifyuser      my $reply=&modifyuser
  ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,   ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
          $desiredhome);           $desiredhome,$email);
     unless ($reply eq 'ok') { return $reply; }      unless ($reply eq 'ok') { return $reply; }
     # 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
Line 3062  sub GetFileTimestamp { Line 3089  sub GetFileTimestamp {
     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;      $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
     my $proname="$studentDomain/$subdir/$studentName";      my $proname="$studentDomain/$subdir/$studentName";
     $proname .= '/'.$filename;      $proname .= '/'.$filename;
     my @dir = &Apache::lonnet::dirlist($proname, $studentDomain, $studentName,      my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, 
                                        $root);                                                $studentName, $root);
     my $fileStat = $dir[0];  
     my @stats = split('&', $fileStat);      my @stats = split('&', $fileStat);
     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {      if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
         return $stats[9];          # @stats contains first the filename, then the stat output
           return $stats[10]; # so this is 10 instead of 9.
     } else {      } else {
         return -1;          return -1;
     }      }
Line 3163  sub courseresdata { Line 3190  sub courseresdata {
     return undef;      return undef;
 }  }
   
 # --------------------------------------------------------- Value of a Variable  #
   # EXT resource caching routines
   #
   
   sub clear_EXT_cache_status {
       &delenv('cache.EXT.');
   }
   
   sub EXT_cache_status {
       my ($target_domain,$target_user) = @_;
       my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
       if (exists($ENV{$cachename}) && ($ENV{$cachename}+1800) > time) {
           # We know already the user has no data
           return 1;
       } else {
           return 0;
       }
   }
   
   sub EXT_cache_set {
       my ($target_domain,$target_user) = @_;
       my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
       &appenv($cachename => time);
   }
   
   # --------------------------------------------------------- Value of a Variable
 sub EXT {  sub EXT {
     my ($varname,$symbparm,$udom,$uname,)=@_;      my ($varname,$symbparm,$udom,$uname,$usection)=@_;
   
     unless ($varname) { return ''; }      unless ($varname) { return ''; }
     #get real user name/domain, courseid and symb      #get real user name/domain, courseid and symb
Line 3174  sub EXT { Line 3225  sub EXT {
     my $publicuser;      my $publicuser;
     if (!($uname && $udom)) {      if (!($uname && $udom)) {
       (my $cursymb,$courseid,$udom,$uname,$publicuser)=        (my $cursymb,$courseid,$udom,$uname,$publicuser)=
   &Apache::lonxml::whichuser();    &Apache::lonxml::whichuser($symbparm);
       if (!$symbparm) { $symbparm=$cursymb; }        if (!$symbparm) { $symbparm=$cursymb; }
     } else {      } else {
  $courseid=$ENV{'request.course.id'};   $courseid=$ENV{'request.course.id'};
Line 3251  sub EXT { Line 3302  sub EXT {
         }          }
     } elsif ($realm eq 'query') {      } elsif ($realm eq 'query') {
 # ---------------------------------------------- pull stuff out of query string  # ---------------------------------------------- pull stuff out of query string
         &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},[$space]);          &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},
  return $ENV{'form.'.$space};    [$spacequalifierrest]);
    return $ENV{'form.'.$spacequalifierrest}; 
    } elsif ($realm eq 'request') {     } elsif ($realm eq 'request') {
 # ------------------------------------------------------------- request.browser  # ------------------------------------------------------------- request.browser
         if ($space eq 'browser') {          if ($space eq 'browser') {
Line 3283  sub EXT { Line 3335  sub EXT {
  ($ENV{'user.domain'} eq $udom)) {   ($ENV{'user.domain'} eq $udom)) {
  $section=$ENV{'request.course.sec'};   $section=$ENV{'request.course.sec'};
     } else {      } else {
  $section=&usection($udom,$uname,$courseid);                  if (! defined($usection)) {
                       $section=&usection($udom,$uname,$courseid);
                   } else {
                       $section = $usection;
                   }
     }      }
   
     my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;      my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
Line 3295  sub EXT { Line 3351  sub EXT {
     my $courselevelm=$courseid.'.'.$mapparm;      my $courselevelm=$courseid.'.'.$mapparm;
   
 # ----------------------------------------------------------- first, check user  # ----------------------------------------------------------- first, check user
     #most student don't have any data set, check if there is some data      #most student don\'t have any data set, check if there is some data
             #every thirty minutes              #every thirty minutes
     if (!      if (! &EXT_cache_status($udom,$uname)) {
  (exists($ENV{'cache.studentresdata'})  
     && (($ENV{'cache.studentresdata'}+1800) > time))) {  
  my %resourcedata=&get('resourcedata',   my %resourcedata=&get('resourcedata',
       [$courselevelr,$courselevelm,$courselevel],        [$courselevelr,$courselevelm,$courselevel],
       $udom,$uname);        $udom,$uname);
Line 3318  sub EXT { Line 3372  sub EXT {
  $uname." at ".$udom.": ".   $uname." at ".$udom.": ".
  $tmp."</font>");   $tmp."</font>");
     } elsif ($tmp=~/error:No such file/) {      } elsif ($tmp=~/error:No such file/) {
  $ENV{'cache.studentresdata'}=time;                          &EXT_cache_set($udom,$uname);
  &appenv(('cache.studentresdata'=>  
  $ENV{'cache.studentresdata'}));  
     } elsif ($tmp =~ /^(con_lost|no_such_host)/) {      } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
  return $tmp;   return $tmp;
     }      }
Line 3606  sub gettitle { Line 3658  sub gettitle {
  unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }   unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }
         return &metadata($urlsymb,'title');           return &metadata($urlsymb,'title'); 
     }      }
     if ($titlecache{$symb}) { return $titlecache{$symb}; }      if ($titlecache{$symb}) {
    if (time < ($titlecache{$symb}[1] + 600)) {
       return $titlecache{$symb}[0];
    } else {
       delete($titlecache{$symb});
    }
       }
     my ($map,$resid,$url)=split(/\_\_\_/,$symb);      my ($map,$resid,$url)=split(/\_\_\_/,$symb);
     my $title='';      my $title='';
     my %bighash;      my %bighash;
Line 3618  sub gettitle { Line 3676  sub gettitle {
     }      }
     $title=~s/\&colon\;/\:/gs;      $title=~s/\&colon\;/\:/gs;
     if ($title) {      if ($title) {
         $titlecache{$symb}=$title;          $titlecache{$symb}=[$title,time];
         return $title;          return $title;
     } else {      } else {
  return &metadata($urlsymb,'title');   return &metadata($urlsymb,'title');
Removed from v.1.370  
changed lines
  Added in v.1.387

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