[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.574 and 1.589

version 1.574, 2004/12/06 18:08:39 version 1.589, 2005/01/18 22:09: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 1406  sub finishuserfileupload { Line 1387  sub finishuserfileupload {
     }      }
 # Save the file  # Save the file
     {      {
  #&Apache::lonnet::logthis("Saving to $filepath $file");  
  open(FH,'>'.$filepath.'/'.$file);   open(FH,'>'.$filepath.'/'.$file);
  print FH $ENV{'form.'.$formname};   print FH $ENV{'form.'.$formname};
  close(FH);   close(FH);
     }      }
 # Notify homeserver to grep it  # Notify homeserver to grep it
 #  #
       &Apache::lonnet::logthis("fetching ".$path.$file);
     my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);      my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
     if ($fetchresult eq 'ok') {      if ($fetchresult eq 'ok') {
 #  #
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 1644  sub get_course_adv_roles { Line 1637  sub get_course_adv_roles {
         if (($tend) && ($tend<$now)) { next; }          if (($tend) && ($tend<$now)) { next; }
         if (($tstart) && ($now<$tstart)) { next; }          if (($tstart) && ($now<$tstart)) { next; }
         my ($role,$username,$domain,$section)=split(/\:/,$_);          my ($role,$username,$domain,$section)=split(/\:/,$_);
    if ($username eq '' || $domain eq '') { next; }
  if ((&privileged($username,$domain)) &&    if ((&privileged($username,$domain)) && 
     (!$nothide{$username.':'.$domain})) { next; }      (!$nothide{$username.':'.$domain})) { next; }
         my $key=&plaintext($role);          my $key=&plaintext($role);
Line 1745  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 2363  sub privileged { Line 2365  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 2395  sub rolesinit { Line 2397  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);      
             $userroles.=&set_arearole($trole,$area,$tstart,$tend);              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);
             if (($tend!=0) && ($tend<$now)) { $trole=''; }              if (($tend!=0) && ($tend<$now)) { $trole=''; }
             if (($tstart!=0) && ($tstart>$now)) { $trole=''; }              if (($tstart!=0) && ($tstart>$now)) { $trole=''; }
             if (($area ne '') && ($trole ne '')) {              if (($area ne '') && ($trole ne '')) {
Line 2776  sub customaccess { Line 2785  sub customaccess {
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri)=@_;      my ($priv,$uri,$symb)=@_;
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
     $uri=&declutter($uri);      $uri=&declutter($uri);
Line 3057  sub allowed { Line 3066  sub allowed {
   
    if ($thisallowed=~/X/) {     if ($thisallowed=~/X/) {
       if ($ENV{'acc.randomout'}) {        if ($ENV{'acc.randomout'}) {
          my $symb=&symbread($uri,1);   if (!$symb) { $symb=&symbread($uri,1); }
          if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) {            if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) { 
             return '';               return ''; 
          }           }
Line 3359  sub auto_instcode_format { Line 3368  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 3818  sub save_selected_files { Line 3834  sub save_selected_files {
     my ($user, $path, @files) = @_;      my ($user, $path, @files) = @_;
     my $filename = $user."savedfiles";      my $filename = $user."savedfiles";
     my @other_files = &files_not_in_path($user, $path);      my @other_files = &files_not_in_path($user, $path);
     foreach (@other_files) {  
         &logthis("other dir file $_");  
     }  
     foreach (@files) {  
         &logthis("current dir file $_");  
     }  
     open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);      open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
     foreach my $file (@files) {      foreach my $file (@files) {
         print (OUT $ENV{'form.currentpath'}.$file."\n");          print (OUT $ENV{'form.currentpath'}.$file."\n");
Line 3906  sub get_marked_as_readonly { Line 3916  sub get_marked_as_readonly {
     }      }
     return @readonly_files;      return @readonly_files;
 }  }
   #-----------------------------------------------------------Get Marked as Read Only Hash
   
   sub get_marked_as_readonly_hash {
       my ($domain,$user,$what) = @_;
       my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
       my %readonly_files;
       while (my ($file_name,$value) = each(%current_permissions)) {
           if (ref($value) eq "ARRAY"){
               foreach my $stored_what (@{$value}) {
                   if ($stored_what eq $what) {
                       $readonly_files{$file_name} = 'locked';
                   } elsif (!defined($what)) {
                       $readonly_files{$file_name} = 'locked';
                   }
               }
           } 
       }
       return %readonly_files;
   }
 # ------------------------------------------------------------ Unmark as Read Only  # ------------------------------------------------------------ Unmark as Read Only
   
 sub unmark_as_readonly {  sub unmark_as_readonly {
Line 4418  sub packages_tab_default { Line 4446  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 4699  sub gettitle { Line 4728  sub gettitle {
     my $symb=&symbread($urlsymb);      my $symb=&symbread($urlsymb);
     if ($symb) {      if ($symb) {
  my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);   my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
  if (defined($cached)) { return $result; }   if (defined($cached)) { 
       return $result;
    }
  my ($map,$resid,$url)=&decode_symb($symb);   my ($map,$resid,$url)=&decode_symb($symb);
  my $title='';   my $title='';
  my %bighash;   my %bighash;
Line 4775  sub symbverify { Line 4806  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 4971  sub numval2 { Line 5005  sub numval2 {
     return int($total);      return int($total);
 }  }
   
   sub numval3 {
       use integer;
       my $txt=shift;
       $txt=~tr/A-J/0-9/;
       $txt=~tr/a-j/0-9/;
       $txt=~tr/K-T/0-9/;
       $txt=~tr/k-t/0-9/;
       $txt=~tr/U-Z/0-5/;
       $txt=~tr/u-z/0-5/;
       $txt=~s/\D//g;
       my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
       my $total;
       foreach my $val (@txts) { $total+=$val; }
       if ($_64bit) { $total=(($total<<32)>>32); }
       return $total;
   }
   
 sub latest_rnd_algorithm_id {  sub latest_rnd_algorithm_id {
     return '64bit3';      return '64bit4';
 }  }
   
 sub get_rand_alg {  sub get_rand_alg {
Line 5011  sub rndseed { Line 5062  sub rndseed {
     if (!$username) { $username=$wusername }      if (!$username) { $username=$wusername }
     my $which=&get_rand_alg();      my $which=&get_rand_alg();
     if (defined(&getCODE())) {      if (defined(&getCODE())) {
  return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);   if ($which eq '64bit4') {
       return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);
    } else {
       return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
    }
       } elsif ($which eq '64bit4') {
    return &rndseed_64bit4($symb,$courseid,$domain,$username);
     } elsif ($which eq '64bit3') {      } elsif ($which eq '64bit3') {
  return &rndseed_64bit3($symb,$courseid,$domain,$username);   return &rndseed_64bit3($symb,$courseid,$domain,$username);
     } elsif ($which eq '64bit2') {      } elsif ($which eq '64bit2') {
Line 5108  sub rndseed_64bit3 { Line 5165  sub rndseed_64bit3 {
     }      }
 }  }
   
   sub rndseed_64bit4 {
       my ($symb,$courseid,$domain,$username)=@_;
       {
    use integer;
    # strings need to be an even # of cahracters long, it it is odd the
           # last characters gets thrown away
    my $symbchck=unpack("%32S*",$symb.' ') << 21;
    my $symbseed=numval3($symb) << 10;
    my $namechck=unpack("%32S*",$username.' ');
   
    my $nameseed=numval3($username) << 21;
    my $domainseed=unpack("%32S*",$domain.' ') << 10;
    my $courseseed=unpack("%32S*",$courseid.' ');
   
    my $num1=$symbchck+$symbseed+$namechck;
    my $num2=$nameseed+$domainseed+$courseseed;
    #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
    #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit");
    if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
   
    return "$num1:$num2";
       }
   }
   
 sub rndseed_CODE_64bit {  sub rndseed_CODE_64bit {
     my ($symb,$courseid,$domain,$username)=@_;      my ($symb,$courseid,$domain,$username)=@_;
     {      {
Line 5127  sub rndseed_CODE_64bit { Line 5208  sub rndseed_CODE_64bit {
     }      }
 }  }
   
   sub rndseed_CODE_64bit4 {
       my ($symb,$courseid,$domain,$username)=@_;
       {
    use integer;
    my $symbchck=unpack("%32S*",$symb.' ') << 16;
    my $symbseed=numval3($symb);
    my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
    my $CODEseed=numval3(&getCODE());
    my $courseseed=unpack("%32S*",$courseid.' ');
    my $num1=$symbseed+$CODEchck;
    my $num2=$CODEseed+$courseseed+$symbchck;
    #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
    #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
    if ($_64bit) { $num1=(($num1<<32)>>32); }
    if ($_64bit) { $num2=(($num2<<32)>>32); }
    return "$num1:$num2";
       }
   }
   
 sub setup_random_from_rndseed {  sub setup_random_from_rndseed {
     my ($rndseed)=@_;      my ($rndseed)=@_;
     if ($rndseed =~/([,:])/) {      if ($rndseed =~/([,:])/) {
Line 5465  sub thaw_unescape { Line 5565  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 5501  BEGIN { Line 5601  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 6136  returns the data handle Line 6237  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.574  
changed lines
  Added in v.1.589

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