[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.579 and 1.592

version 1.579, 2004/12/17 22:40:09 version 1.592, 2005/01/31 11:27:14
Line 157  sub reply { Line 157  sub reply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     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') {  
         #sleep 5;   
         #$answer=subreply($cmd,$server);  
         #if ($answer eq 'con_lost') {  
  #   &logthis("Second attempt con_lost on $server");  
         #   my $peerfile="$perlvar{'lonSockDir'}/$server";  
         #   my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",  
         #                                    Type    => SOCK_STREAM,  
         #                                    Timeout => 10)  
         #              or return "con_lost";  
         #   &logthis("Killing socket");  
         #   print $client "close_connection_exit\n";  
            #sleep 5;  
         #   $answer=subreply($cmd,$server);         
        #}     
     }  
     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {      if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
        &logthis("<font color=blue>WARNING:".         &logthis("<font color=blue>WARNING:".
                 " $cmd to $server returned $answer</font>");                  " $cmd to $server returned $answer</font>");
Line 220  sub critical { Line 204  sub critical {
     }      }
     my $answer=reply($cmd,$server);      my $answer=reply($cmd,$server);
     if ($answer eq 'con_lost') {      if ($answer eq 'con_lost') {
         my $pingreply=reply('ping',$server);  
  &reconlonc("$perlvar{'lonSockDir'}/$server");   &reconlonc("$perlvar{'lonSockDir'}/$server");
         my $pongreply=reply('pong',$server);   my $answer=reply($cmd,$server);
         &logthis("Ping/Pong for $server: $pingreply/$pongreply");  
         $answer=reply($cmd,$server);  
         if ($answer eq 'con_lost') {          if ($answer eq 'con_lost') {
             my $now=time;              my $now=time;
             my $middlename=$cmd;              my $middlename=$cmd;
Line 1588  sub courseacclog { Line 1569  sub courseacclog {
     my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};      my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
     if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) {      if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) {
         $what.=':POST';          $what.=':POST';
           # FIXME: Probably ought to escape things....
  foreach (keys %ENV) {   foreach (keys %ENV) {
             if ($_=~/^form\.(.*)/) {              if ($_=~/^form\.(.*)/) {
  $what.=':'.$1.'='.$ENV{$_};   $what.=':'.$1.'='.$ENV{$_};
             }              }
         }          }
       } elsif ($fnsymb =~ m:^/adm/searchcat:) {
           # FIXME: We should not be depending on a form parameter that someone
           # editing lonsearchcat.pm might change in the future.
           if ($ENV{'form.phase'} eq 'course_search') {
               $what.= ':POST';
               # FIXME: Probably ought to escape things....
               foreach my $element ('courseexp','crsfulltext','crsrelated',
                                    'crsdiscuss') {
                   $what.=':'.$element.'='.$ENV{'form.'.$element};
               }
           }
     }      }
     &courselog($what);      &courselog($what);
 }  }
Line 1746  sub get_first_access { Line 1739  sub get_first_access {
     my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();      my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
     if ($argsymb) { $symb=$argsymb; }      if ($argsymb) { $symb=$argsymb; }
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'map') { $res=$map; }      if ($type eq 'map') {
     my %times=&get('firstaccesstimes',[$res],$udom,$uname);   $res=&symbread($map);
     return $times{$res};      } else {
    $res=$symb;
       }
       my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname);
       return $times{"$courseid\0$res"};
 }  }
   
 sub set_first_access {  sub set_first_access {
     my ($type)=@_;      my ($type)=@_;
     my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();      my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'map') { $res=$map; }      if ($type eq 'map') {
     my $firstaccess=&get_first_access($type);   $res=&symbread($map);
       } else {
    $res=$symb;
       }
       my $firstaccess=&get_first_access($type,$symb);
     if (!$firstaccess) {      if (!$firstaccess) {
  return &put('firstaccesstimes',{$res=>time},$udom,$uname);   return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);
     }      }
     return 'already_set';      return 'already_set';
 }  }
Line 2099  sub tmpreset { Line 2100  sub tmpreset {
   $namespace=~s/\//\_/g;    $namespace=~s/\//\_/g;
   $namespace=~s/\W//g;    $namespace=~s/\W//g;
   
   #FIXME needs to do something for /pub resources  
   if (!$domain) { $domain=$ENV{'user.domain'}; }    if (!$domain) { $domain=$ENV{'user.domain'}; }
   if (!$stuname) { $stuname=$ENV{'user.name'}; }    if (!$stuname) { $stuname=$ENV{'user.name'}; }
     if ($domain eq 'public' && $stuname eq 'public') {
         $stuname=$ENV{'REMOTE_ADDR'};
     }
   my $path=$perlvar{'lonDaemons'}.'/tmp';    my $path=$perlvar{'lonDaemons'}.'/tmp';
   my %hash;    my %hash;
   if (tie(%hash,'GDBM_File',    if (tie(%hash,'GDBM_File',
Line 2134  sub tmpstore { Line 2137  sub tmpstore {
   }    }
   $namespace=~s/\//\_/g;    $namespace=~s/\//\_/g;
   $namespace=~s/\W//g;    $namespace=~s/\W//g;
 #FIXME needs to do something for /pub resources  
   if (!$domain) { $domain=$ENV{'user.domain'}; }    if (!$domain) { $domain=$ENV{'user.domain'}; }
   if (!$stuname) { $stuname=$ENV{'user.name'}; }    if (!$stuname) { $stuname=$ENV{'user.name'}; }
     if ($domain eq 'public' && $stuname eq 'public') {
         $stuname=$ENV{'REMOTE_ADDR'};
     }
   my $now=time;    my $now=time;
   my %hash;    my %hash;
   my $path=$perlvar{'lonDaemons'}.'/tmp';    my $path=$perlvar{'lonDaemons'}.'/tmp';
Line 2148  sub tmpstore { Line 2153  sub tmpstore {
     my $allkeys='';       my $allkeys=''; 
     foreach my $key (keys(%$storehash)) {      foreach my $key (keys(%$storehash)) {
       $allkeys.=$key.':';        $allkeys.=$key.':';
       $hash{"$version:$symb:$key"}=$$storehash{$key};        $hash{"$version:$symb:$key"}=&freeze_escape($$storehash{$key});
     }      }
     $hash{"$version:$symb:timestamp"}=$now;      $hash{"$version:$symb:timestamp"}=$now;
     $allkeys.='timestamp';      $allkeys.='timestamp';
Line 2175  sub tmprestore { Line 2180  sub tmprestore {
   $symb=escape($symb);    $symb=escape($symb);
   
   if (!$namespace) { $namespace=$ENV{'request.state'}; }    if (!$namespace) { $namespace=$ENV{'request.state'}; }
   #FIXME needs to do something for /pub resources  
   if (!$domain) { $domain=$ENV{'user.domain'}; }    if (!$domain) { $domain=$ENV{'user.domain'}; }
   if (!$stuname) { $stuname=$ENV{'user.name'}; }    if (!$stuname) { $stuname=$ENV{'user.name'}; }
     if ($domain eq 'public' && $stuname eq 'public') {
         $stuname=$ENV{'REMOTE_ADDR'};
     }
   my %returnhash;    my %returnhash;
   $namespace=~s/\//\_/g;    $namespace=~s/\//\_/g;
   $namespace=~s/\W//g;    $namespace=~s/\W//g;
Line 2196  sub tmprestore { Line 2203  sub tmprestore {
       my $key;        my $key;
       $returnhash{"$scope:keys"}=$vkeys;        $returnhash{"$scope:keys"}=$vkeys;
       foreach $key (@keys) {        foreach $key (@keys) {
  $returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"};   $returnhash{"$scope:$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
  $returnhash{"$key"}=$hash{"$scope:$symb:$key"};   $returnhash{"$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
       }        }
     }      }
     if (!(untie(%hash))) {      if (!(untie(%hash))) {
Line 2238  sub store { Line 2245  sub store {
   
     my $namevalue='';      my $namevalue='';
     foreach (keys %$storehash) {      foreach (keys %$storehash) {
         $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';          $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
     }      }
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);      &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
Line 2274  sub cstore { Line 2281  sub cstore {
   
     my $namevalue='';      my $namevalue='';
     foreach (keys %$storehash) {      foreach (keys %$storehash) {
         $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';          $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
     }      }
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);      &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
Line 2308  sub restore { Line 2315  sub restore {
     my %returnhash=();      my %returnhash=();
     foreach (split(/\&/,$answer)) {      foreach (split(/\&/,$answer)) {
  my ($name,$value)=split(/\=/,$_);   my ($name,$value)=split(/\=/,$_);
         $returnhash{&unescape($name)}=&unescape($value);          $returnhash{&unescape($name)}=&thaw_unescape($value);
     }      }
     my $version;      my $version;
     for ($version=1;$version<=$returnhash{'version'};$version++) {      for ($version=1;$version<=$returnhash{'version'};$version++) {
Line 2364  sub privileged { Line 2371  sub privileged {
     my $now=time;      my $now=time;
     if ($rolesdump ne '') {      if ($rolesdump ne '') {
         foreach (split(/&/,$rolesdump)) {          foreach (split(/&/,$rolesdump)) {
     if ($_!~/^rolesdef\&/) {      if ($_!~/^rolesdef_/) {
  my ($area,$role)=split(/=/,$_);   my ($area,$role)=split(/=/,$_);
  $area=~s/\_\w\w$//;   $area=~s/\_\w\w$//;
  my ($trole,$tend,$tstart)=split(/_/,$role);   my ($trole,$tend,$tstart)=split(/_/,$role);
Line 2396  sub rolesinit { Line 2403  sub rolesinit {
   
     if ($rolesdump ne '') {      if ($rolesdump ne '') {
         foreach (split(/&/,$rolesdump)) {          foreach (split(/&/,$rolesdump)) {
   if ($_!~/^rolesdef\&/) {    if ($_!~/^rolesdef_/) {
             my ($area,$role)=split(/=/,$_);              my ($area,$role)=split(/=/,$_);
             $area=~s/\_\w\w$//;      $area=~s/\_\w\w$//;
             my ($trole,$tend,$tstart)=split(/_/,$role);      
               my ($trole,$tend,$tstart);
       if ($role=~/^cr/) { 
    ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|);
    ($tend,$tstart)=split('_',$trest);
       } else {
    ($trole,$tend,$tstart)=split(/_/,$role);
       }
             $userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username);              $userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username);
             if (($tend!=0) && ($tend<$now)) { $trole=''; }              if (($tend!=0) && ($tend<$now)) { $trole=''; }
             if (($tstart!=0) && ($tstart>$now)) { $trole=''; }              if (($tstart!=0) && ($tstart>$now)) { $trole=''; }
Line 2692  sub putstore { Line 2706  sub putstore {
            my $key = $1.':keys:'.$2;             my $key = $1.':keys:'.$2;
            $allitems{$key} .= $3.':';             $allitems{$key} .= $3.':';
        }         }
        $items.=$_.'='.&escape($$storehash{$_}).'&';         $items.=$_.'='.&freeze_escape($$storehash{$_}).'&';
    }     }
    foreach (keys %allitems) {     foreach (keys %allitems) {
        $allitems{$_} =~ s/\:$//;         $allitems{$_} =~ s/\:$//;
Line 3360  sub auto_instcode_format { Line 3374  sub auto_instcode_format {
     my $courses = '';      my $courses = '';
     my $homeserver;      my $homeserver;
     if ($caller eq 'global') {      if ($caller eq 'global') {
         $homeserver = $perlvar{'lonHostID'};          foreach my $tryserver (keys %libserv) {
               if ($hostdom{$tryserver} eq $codedom) {
                   $homeserver = $tryserver;
                   last;
               }
           }
           if (($ENV{'user.name'}) && ($ENV{'user.domain'} eq $codedom)) {
               $homeserver = &homeserver($ENV{'user.name'},$codedom);
           }
     } else {      } else {
         $homeserver = &homeserver($caller,$codedom);          $homeserver = &homeserver($caller,$codedom);
     }      }
     my $host=$hostname{$homeserver};  
     foreach (keys %{$instcodes}) {      foreach (keys %{$instcodes}) {
         $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';          $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';
     }      }
Line 3555  sub modifyuser { Line 3576  sub modifyuser {
     if (defined($middle)) { $names{'middlename'} = $middle; }      if (defined($middle)) { $names{'middlename'} = $middle; }
     if ($last)   { $names{'lastname'}   = $last; }      if ($last)   { $names{'lastname'}   = $last; }
     if (defined($gene))   { $names{'generation'} = $gene; }      if (defined($gene))   { $names{'generation'} = $gene; }
     if ($email)  { $names{'notification'} = $email;      if ($email) {
                    $names{'critnotification'} = $email; }         $email=~s/[^\w\@\.\-\,]//gs;
          if ($email=~/\@/) { $names{'notification'} = $email;
      $names{'critnotification'} = $email;
      $names{'permanentemail'} = $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 4431  sub packages_tab_default { Line 4455  sub packages_tab_default {
  if (defined($packagetab{"$pack_type&$name&default"})) {   if (defined($packagetab{"$pack_type&$name&default"})) {
     return $packagetab{"$pack_type&$name&default"};      return $packagetab{"$pack_type&$name&default"};
  }   }
    if ($pack_type eq 'part') { $pack_part='0'; }
  if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {   if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {
     return $packagetab{$pack_type."_".$pack_part."&$name&default"};      return $packagetab{$pack_type."_".$pack_part."&$name&default"};
  }   }
Line 4790  sub symbverify { Line 4815  sub symbverify {
                if (                 if (
   &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)    &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
    eq $symb) {      eq $symb) { 
                   $okay=1;      if (($ENV{'request.role.adv'}) ||
                }         $bighash{'encrypted_'.$_} eq $ENV{'request.enc'}) {
          $okay=1; 
      }
          }
    }     }
         }          }
  untie(%bighash);   untie(%bighash);
Line 5414  sub readfile { Line 5442  sub readfile {
 }  }
   
 sub filelocation {  sub filelocation {
   my ($dir,$file) = @_;      my ($dir,$file) = @_;
   my $location;      my $location;
   $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces      $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
   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      } elsif ($file=~/^\/*uploaded/) { # is an uploaded file
       my ($udom,$uname,$filename)=          my ($udom,$uname,$filename)=
   ($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|);       ($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|);
       my $home=&homeserver($uname,$udom);          my $home=&homeserver($uname,$udom);
       my $is_me=0;          my $is_me=0;
       my @ids=&current_machine_ids();          my @ids=&current_machine_ids();
       foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }          foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
       if ($is_me) {          if ($is_me) {
   $location=&Apache::loncommon::propath($udom,$uname).       $location=&Apache::loncommon::propath($udom,$uname).
       '/userfiles/'.$filename;         '/userfiles/'.$filename;
       } else {          } else {
   $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.     $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
       $udom.'/'.$uname.'/'.$filename;         $udom.'/'.$uname.'/'.$filename;
       }          }
   } else {      } elsif ($file =~ /^\/adm\/portfolio\//) {
     $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;          $file =~ s:^/adm/portfolio/::;
     $file=~s:^/res/:/:;          $location = $location=&Apache::loncommon::propath($ENV{'user.domain'},$ENV{'user.name'}).'/userfiles/portfolio/'.$file;
     if ( !( $file =~ m:^/:) ) {      } else {
       $location = $dir. '/'.$file;          $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
     } else {          $file=~s:^/res/:/:;
       $location = '/home/httpd/html/res'.$file;          if ( !( $file =~ m:^/:) ) {
               $location = $dir. '/'.$file;
           } else {
               $location = '/home/httpd/html/res'.$file;
           }
     }      }
   }      $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 /./
   while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./      return $location;
   return $location;  
 }  }
   
 sub hreflocation {  sub hreflocation {
Line 5546  sub thaw_unescape { Line 5577  sub thaw_unescape {
 }  }
   
 sub mod_perl_version {  sub mod_perl_version {
       return 1;
     if (defined($perlvar{'MODPERL2'})) {      if (defined($perlvar{'MODPERL2'})) {
  return 2;   return 2;
     }      }
     return 1;  
 }  }
   
 sub correct_line_ends {  sub correct_line_ends {
Line 5582  BEGIN { Line 5613  BEGIN {
 # ----------------------------------- Read loncapa.conf and loncapa_apache.conf  # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
     unless ($readit) {      unless ($readit) {
 {  {
       # FIXME: Use LONCAPA::Configuration::read_conf here and omit next block
     open(my $config,"</etc/httpd/conf/loncapa.conf");      open(my $config,"</etc/httpd/conf/loncapa.conf");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
Line 6217  returns the data handle Line 6249  returns the data handle
 =item *  =item *
   
 symbverify($symb,$thisfn) : verifies that $symb actually exists and is  symbverify($symb,$thisfn) : verifies that $symb actually exists and is
 a possible symb for the URL in $thisfn, returns a 1 on success, 0 on  a possible symb for the URL in $thisfn, and if is an encryypted
 failure, user must be in a course, as it assumes the existance of the  resource that the user accessed using /enc/ returns a 1 on success, 0
 course initi hash, and uses $ENV('request.course.id'}  on failure, user must be in a course, as it assumes the existance of
   the course initial hash, and uses $ENV('request.course.id'}
   
   
 =item *  =item *
Removed from v.1.579  
changed lines
  Added in v.1.592

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