[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.784 and 1.799

version 1.784, 2006/09/28 01:38:59 version 1.799, 2006/10/23 21:22:44
Line 52  use Storable qw(lock_store lock_nstore l Line 52  use Storable qw(lock_store lock_nstore l
 use Time::HiRes qw( gettimeofday tv_interval );  use Time::HiRes qw( gettimeofday tv_interval );
 use Cache::Memcached;  use Cache::Memcached;
 use Digest::MD5;  use Digest::MD5;
   use Math::Random;
 use lib '/home/httpd/lib/perl';  use lib '/home/httpd/lib/perl';
 use LONCAPA;  use LONCAPA;
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
Line 303  sub convert_and_load_session_env { Line 304  sub convert_and_load_session_env {
     }      }
     my %temp_env;      my %temp_env;
     foreach my $line (@profile) {      foreach my $line (@profile) {
    if ($line !~ m/=/) {
       return 0;
    }
  chomp($line);   chomp($line);
  my ($envname,$envvalue)=split(/=/,$line,2);   my ($envname,$envvalue)=split(/=/,$line,2);
  $temp_env{&unescape($envname)} = &unescape($envvalue);   $temp_env{&unescape($envname)} = &unescape($envvalue);
Line 314  sub convert_and_load_session_env { Line 318  sub convert_and_load_session_env {
  @env{keys(%temp_env)} = @disk_env{keys(%temp_env)};   @env{keys(%temp_env)} = @disk_env{keys(%temp_env)};
  untie(%disk_env);   untie(%disk_env);
     }      }
       return 1;
 }  }
   
 # ------------------------------------------- Transfer profile into environment  # ------------------------------------------- Transfer profile into environment
 my $env_loaded;  my $env_loaded;
 sub transfer_profile_to_env {  sub transfer_profile_to_env {
     if ($env_loaded) { return; }       my ($lonidsdir,$handle,$force_transfer) = @_;
       if (!$force_transfer && $env_loaded) { return; } 
   
     my ($lonidsdir,$handle)=@_;  
     if (!defined($lonidsdir)) {      if (!defined($lonidsdir)) {
  $lonidsdir = $perlvar{'lonIDsDir'};   $lonidsdir = $perlvar{'lonIDsDir'};
     }      }
Line 329  sub transfer_profile_to_env { Line 334  sub transfer_profile_to_env {
         ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );          ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
     }      }
   
     my %remove;      my $convert;
     if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),      {
     0640)) {      open(my $idf,"$lonidsdir/$handle.id");
  @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};   flock($idf,LOCK_SH);
  untie(%disk_env);   if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
     } else {   &GDBM_READER(),0640)) {
  &convert_and_load_session_env($lonidsdir,$handle);      @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
       untie(%disk_env);
    } else {
       $convert = 1;
    }
       }
       if ($convert) {
    if (!&convert_and_load_session_env($lonidsdir,$handle)) {
       &logthis("Failed to load session, or convert session.");
    }
     }      }
   
       my %remove;
     while ( my $envname = each(%env) ) {      while ( my $envname = each(%env) ) {
         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {          if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
             if ($time < time-300) {              if ($time < time-300) {
Line 398  sub delenv { Line 413  sub delenv {
     return 'ok';      return 'ok';
 }  }
   
   sub get_env_multiple {
       my ($name) = @_;
       my @values;
       if (defined($env{$name})) {
           # exists is it an array
           if (ref($env{$name})) {
               @values=@{ $env{$name} };
           } else {
               $values[0]=$env{$name};
           }
       }
       return(@values);
   }
   
 # ------------------------------------------ Find out current server userload  # ------------------------------------------ Find out current server userload
 # there is a copy in lond  # there is a copy in lond
 sub userload {  sub userload {
Line 507  sub compare_server_load { Line 536  sub compare_server_load {
 # --------------------------------------------- Try to change a user's password  # --------------------------------------------- Try to change a user's password
   
 sub changepass {  sub changepass {
     my ($uname,$udom,$currentpass,$newpass,$server)=@_;      my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
     $currentpass = &escape($currentpass);      $currentpass = &escape($currentpass);
     $newpass     = &escape($newpass);      $newpass     = &escape($newpass);
     my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass",      my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context",
        $server);         $server);
     if (! $answer) {      if (! $answer) {
  &logthis("No reply on password change request to $server ".   &logthis("No reply on password change request to $server ".
Line 1170  sub absolute_url { Line 1199  sub absolute_url {
     return $protocol.$host_name;      return $protocol.$host_name;
 }  }
   
 sub absolute_url {  
     my ($host_name) = @_;  
     my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');  
     if ($host_name eq '') {  
  $host_name = $ENV{'SERVER_NAME'};  
     }  
     return $protocol.$host_name;  
 }  
   
 sub ssi {  sub ssi {
   
     my ($fn,%form)=@_;      my ($fn,%form)=@_;
Line 1616  sub removeuploadedurl { Line 1636  sub removeuploadedurl {
 sub removeuserfile {  sub removeuserfile {
     my ($docuname,$docudom,$fname)=@_;      my ($docuname,$docudom,$fname)=@_;
     my $home=&homeserver($docuname,$docudom);      my $home=&homeserver($docuname,$docudom);
     return &reply("removeuserfile:$docudom/$docuname/$fname",$home);      my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
       if ($result eq 'ok') {
           if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
               my $metafile = $fname.'.meta';
               my $metaresult = &removeuserfile($docuname,$docudom,$metafile); 
           }
       }
       return $result;
 }  }
   
 sub mkdiruserfile {  sub mkdiruserfile {
Line 1628  sub mkdiruserfile { Line 1655  sub mkdiruserfile {
 sub renameuserfile {  sub renameuserfile {
     my ($docuname,$docudom,$old,$new)=@_;      my ($docuname,$docudom,$old,$new)=@_;
     my $home=&homeserver($docuname,$docudom);      my $home=&homeserver($docuname,$docudom);
     return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'.      my $result = &reply("renameuserfile:$docudom:$docuname:".
   &escape("$new"),$home);                          &escape("$old").':'.&escape("$new"),$home);
       if ($result eq 'ok') {
           if (($old !~ /\.meta$/) && (&is_portfolio_file($old))) {
               my $oldmeta = $old.'.meta';
               my $newmeta = $new.'.meta';
               my $metaresult = 
                   &renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
           }
       }
       return $result;
 }  }
   
 # ------------------------------------------------------------------------- Log  # ------------------------------------------------------------------------- Log
Line 1948  sub courseidput { Line 1984  sub courseidput {
 }  }
   
 sub courseiddump {  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter)=@_;      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
     my %returnhash=();      my %returnhash=();
     unless ($domfilter) { $domfilter=''; }      unless ($domfilter) { $domfilter=''; }
     foreach my $tryserver (keys %libserv) {      foreach my $tryserver (keys %libserv) {
Line 1957  sub courseiddump { Line 1993  sub courseiddump {
         foreach (          foreach (
                  split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.                   split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
        $sincefilter.':'.&escape($descfilter).':'.         $sincefilter.':'.&escape($descfilter).':'.
                                &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter),                                 &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),
                                $tryserver))) {                                 $tryserver))) {
     my ($key,$value)=split(/\=/,$_);      my ($key,$value)=split(/\=/,$_);
                     if (($key) && ($value)) {                      if (($key) && ($value)) {
Line 2030  sub get_domain_roles { Line 2066  sub get_domain_roles {
   
 sub get_first_access {  sub get_first_access {
     my ($type,$argsymb)=@_;      my ($type,$argsymb)=@_;
     my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();      my ($symb,$courseid,$udom,$uname)=&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') {      if ($type eq 'map') {
Line 2044  sub get_first_access { Line 2080  sub get_first_access {
   
 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)=&whichuser();
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'map') {      if ($type eq 'map') {
  $res=&symbread($map);   $res=&symbread($map);
Line 3424  sub is_portfolio_url { Line 3460  sub is_portfolio_url {
     return scalar(&parse_portfolio_url($url));      return scalar(&parse_portfolio_url($url));
 }  }
   
   sub is_portfolio_file {
       my ($file) = @_;
       if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {
           return 1;
       }
       return;
   }
   
   
 # ---------------------------------------------- Custom access rule evaluation  # ---------------------------------------------- Custom access rule evaluation
   
 sub customaccess {  sub customaccess {
Line 4186  sub auto_photoupdate { Line 4231  sub auto_photoupdate {
 }  }
   
 sub auto_instcode_format {  sub auto_instcode_format {
     my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;      my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,
    $cat_order) = @_;
     my $courses = '';      my $courses = '';
     my @homeservers;      my @homeservers;
     if ($caller eq 'global') {      if ($caller eq 'global') {
         foreach my $tryserver (keys %libserv) {          foreach my $tryserver (keys(%libserv)) {
             if ($hostdom{$tryserver} eq $codedom) {              if ($hostdom{$tryserver} eq $codedom) {
                 if (!grep/^\Q$tryserver\E$/,@homeservers) {                  if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
                     push(@homeservers,$tryserver);                      push(@homeservers,$tryserver);
                 }                  }
             }              }
Line 4200  sub auto_instcode_format { Line 4246  sub auto_instcode_format {
     } else {      } else {
         push(@homeservers,&homeserver($caller,$codedom));          push(@homeservers,&homeserver($caller,$codedom));
     }      }
     foreach (keys %{$instcodes}) {      foreach my $code (keys(%{$instcodes})) {
         $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';          $courses .= &escape($code).'='.&escape($$instcodes{$code}).'&';
     }      }
     chop($courses);      chop($courses);
     my $ok_response = 0;      my $ok_response = 0;
Line 4211  sub auto_instcode_format { Line 4257  sub auto_instcode_format {
         $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);          $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
         if ($response !~ /(con_lost|error|no_such_host|refused)/) {          if ($response !~ /(con_lost|error|no_such_host|refused)/) {
             my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =               my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = 
                                                             split/:/,$response;   split/:/,$response;
             %{$codes} = (%{$codes},&str2hash($codes_str));              %{$codes} = (%{$codes},&str2hash($codes_str));
             push(@{$codetitles},&str2array($codetitles_str));              push(@{$codetitles},&str2array($codetitles_str));
             %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));              %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
Line 4226  sub auto_instcode_format { Line 4272  sub auto_instcode_format {
     }      }
 }  }
   
   sub auto_instcode_defaults {
       my ($domain,$returnhash,$code_order) = @_;
       my @homeservers;
       foreach my $tryserver (keys(%libserv)) {
           if ($hostdom{$tryserver} eq $domain) {
               if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
                   push(@homeservers,$tryserver);
               }
           }
       }
       my $ok_response = 0;
       my $response;
       while (@homeservers > 0 && $ok_response == 0) {
           my $server = shift(@homeservers);
           $response=&reply('autoinstcodedefaults:'.$domain,$server);
           if ($response !~ /(con_lost|error|no_such_host|refused)/) {
               foreach my $pair (split(/\&/,$response)) {
                   my ($name,$value)=split(/\=/,$pair);
                   if ($name eq 'code_order') {
                       @{$code_order} = split(/\&/,&unescape($value));
                   } else {
                       $returnhash->{&unescape($name)}=&unescape($value);
                   }
               }
           }
           $ok_response = 1;
       }
       if ($ok_response) {
           return 'ok';
       } else {
           return $response;
       }
   } 
   
 sub auto_validate_class_sec {  sub auto_validate_class_sec {
     my ($cdom,$cnum,$owner,$inst_class) = @_;      my ($cdom,$cnum,$owner,$inst_class) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
Line 4971  sub modify_access_controls { Line 5051  sub modify_access_controls {
             for (my $i=0; $i<$numnew; $i++) {              for (my $i=0; $i<$numnew; $i++) {
                 my $newkey = $newitems[$i];                  my $newkey = $newitems[$i];
                 my $newid = &Apache::loncommon::get_cgi_id();                  my $newid = &Apache::loncommon::get_cgi_id();
                 $newkey =~ s/^(\d+)/$newid/;                  if ($newkey =~ /^\d+:/) { 
                 $translation{$1} = $newid;                      $newkey =~ s/^(\d+)/$newid/;
                       $translation{$1} = $newid;
                   } elsif ($newkey =~ /^\d+_\d+_\d+:/) {
                       $newkey =~ s/^(\d+_\d+_\d+)/$newid/;
                       $translation{$1} = $newid;
                   }
                 $new_values{$file_name."\0".$newkey} =                   $new_values{$file_name."\0".$newkey} = 
                                           $$changes{'activate'}{$newitems[$i]};                                            $$changes{'activate'}{$newitems[$i]};
                 $new_control{$newkey} = $now;                  $new_control{$newkey} = $now;
Line 5272  sub GetFileTimestamp { Line 5357  sub GetFileTimestamp {
   
 sub stat_file {  sub stat_file {
     my ($uri) = @_;      my ($uri) = @_;
     $uri = &clutter($uri);      $uri = &clutter_with_no_wrapper($uri);
   
     # we want just the url part without the unneeded accessor url bits  
     if ($uri =~ m-^/adm/-) {  
  $uri=~s-^/adm/wrapper/-/-;  
  $uri=~s-^/adm/coursedocs/showdoc/-/-;  
     }  
     my ($udom,$uname,$file,$dir);      my ($udom,$uname,$file,$dir);
     if ($uri =~ m-^/(uploaded|editupload)/-) {      if ($uri =~ m-^/(uploaded|editupload)/-) {
  ($udom,$uname,$file) =   ($udom,$uname,$file) =
Line 5510  sub EXT { Line 5590  sub EXT {
  $symbparm=&get_symb_from_alias($symbparm);   $symbparm=&get_symb_from_alias($symbparm);
     }      }
     if (!($uname && $udom)) {      if (!($uname && $udom)) {
       (my $cursymb,$courseid,$udom,$uname,$publicuser)=        (my $cursymb,$courseid,$udom,$uname,$publicuser)= &whichuser($symbparm);
   &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 6165  sub gettitle { Line 6244  sub gettitle {
 sub get_slot {  sub get_slot {
     my ($which,$cnum,$cdom)=@_;      my ($which,$cnum,$cdom)=@_;
     if (!$cnum || !$cdom) {      if (!$cnum || !$cdom) {
  (undef,my $courseid)=&Apache::lonxml::whichuser();   (undef,my $courseid)=&whichuser();
  $cdom=$env{'course.'.$courseid.'.domain'};   $cdom=$env{'course.'.$courseid.'.domain'};
  $cnum=$env{'course.'.$courseid.'.num'};   $cnum=$env{'course.'.$courseid.'.num'};
     }      }
Line 6214  sub symblist { Line 6293  sub symblist {
 sub symbverify {  sub symbverify {
     my ($symb,$thisurl)=@_;      my ($symb,$thisurl)=@_;
     my $thisfn=$thisurl;      my $thisfn=$thisurl;
 # wrapper not part of symbs  
     $thisfn=~s/^\/adm\/wrapper//;  
     $thisfn=~s/^\/adm\/coursedocs\/showdoc\///;  
     $thisfn=&declutter($thisfn);      $thisfn=&declutter($thisfn);
 # direct jump to resource in page or to a sequence - will construct own symbs  # direct jump to resource in page or to a sequence - will construct own symbs
     if ($thisfn=~/\.(page|sequence)$/) { return 1; }      if ($thisfn=~/\.(page|sequence)$/) { return 1; }
Line 6499  sub latest_rnd_algorithm_id { Line 6575  sub latest_rnd_algorithm_id {
   
 sub get_rand_alg {  sub get_rand_alg {
     my ($courseid)=@_;      my ($courseid)=@_;
     if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; }      if (!$courseid) { $courseid=(&whichuser())[1]; }
     if ($courseid) {      if ($courseid) {
  return $env{"course.$courseid.rndseed"};   return $env{"course.$courseid.rndseed"};
     }      }
Line 6525  sub getCODE { Line 6601  sub getCODE {
 sub rndseed {  sub rndseed {
     my ($symb,$courseid,$domain,$username)=@_;      my ($symb,$courseid,$domain,$username)=@_;
   
     my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser();      my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
     if (!$symb) {      if (!$symb) {
  unless ($symb=$wsymb) { return time; }   unless ($symb=$wsymb) { return time; }
     }      }
Line 6566  sub rndseed_32bit { Line 6642  sub rndseed_32bit {
  my $domainseed=unpack("%32C*",$domain) << 7;   my $domainseed=unpack("%32C*",$domain) << 7;
  my $courseseed=unpack("%32C*",$courseid);   my $courseseed=unpack("%32C*",$courseid);
  my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;   my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num:$symb");   #&logthis("rndseed :$num:$symb");
  if ($_64bit) { $num=(($num<<32)>>32); }   if ($_64bit) { $num=(($num<<32)>>32); }
  return $num;   return $num;
     }      }
Line 6587  sub rndseed_64bit { Line 6663  sub rndseed_64bit {
   
  my $num1=$symbchck+$symbseed+$namechck;   my $num1=$symbchck+$symbseed+$namechck;
  my $num2=$nameseed+$domainseed+$courseseed;   my $num2=$nameseed+$domainseed+$courseseed;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num:$symb");   #&logthis("rndseed :$num:$symb");
  if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }   if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
  if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }   if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
  return "$num1,$num2";   return "$num1,$num2";
Line 6611  sub rndseed_64bit2 { Line 6687  sub rndseed_64bit2 {
   
  my $num1=$symbchck+$symbseed+$namechck;   my $num1=$symbchck+$symbseed+$namechck;
  my $num2=$nameseed+$domainseed+$courseseed;   my $num2=$nameseed+$domainseed+$courseseed;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num:$symb");   #&logthis("rndseed :$num:$symb");
  return "$num1,$num2";   return "$num1,$num2";
     }      }
 }  }
Line 6633  sub rndseed_64bit3 { Line 6709  sub rndseed_64bit3 {
   
  my $num1=$symbchck+$symbseed+$namechck;   my $num1=$symbchck+$symbseed+$namechck;
  my $num2=$nameseed+$domainseed+$courseseed;   my $num2=$nameseed+$domainseed+$courseseed;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit");   #&logthis("rndseed :$num1:$num2:$_64bit");
  if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }   if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
   
  return "$num1:$num2";   return "$num1:$num2";
Line 6657  sub rndseed_64bit4 { Line 6733  sub rndseed_64bit4 {
   
  my $num1=$symbchck+$symbseed+$namechck;   my $num1=$symbchck+$symbseed+$namechck;
  my $num2=$nameseed+$domainseed+$courseseed;   my $num2=$nameseed+$domainseed+$courseseed;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit");   #&logthis("rndseed :$num1:$num2:$_64bit");
  if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }   if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
   
  return "$num1:$num2";   return "$num1:$num2";
Line 6682  sub rndseed_CODE_64bit { Line 6758  sub rndseed_CODE_64bit {
  my $courseseed=unpack("%32S*",$courseid.' ');   my $courseseed=unpack("%32S*",$courseid.' ');
  my $num1=$symbseed+$CODEchck;   my $num1=$symbseed+$CODEchck;
  my $num2=$CODEseed+$courseseed+$symbchck;   my $num2=$CODEseed+$courseseed+$symbchck;
  #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");   #&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");   #&logthis("rndseed :$num1:$num2:$symb");
  if ($_64bit) { $num1=(($num1<<32)>>32); }   if ($_64bit) { $num1=(($num1<<32)>>32); }
  if ($_64bit) { $num2=(($num2<<32)>>32); }   if ($_64bit) { $num2=(($num2<<32)>>32); }
  return "$num1:$num2";   return "$num1:$num2";
Line 6701  sub rndseed_CODE_64bit4 { Line 6777  sub rndseed_CODE_64bit4 {
  my $courseseed=unpack("%32S*",$courseid.' ');   my $courseseed=unpack("%32S*",$courseid.' ');
  my $num1=$symbseed+$CODEchck;   my $num1=$symbseed+$CODEchck;
  my $num2=$CODEseed+$courseseed+$symbchck;   my $num2=$CODEseed+$courseseed+$symbchck;
  #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");   #&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");   #&logthis("rndseed :$num1:$num2:$symb");
  if ($_64bit) { $num1=(($num1<<32)>>32); }   if ($_64bit) { $num1=(($num1<<32)>>32); }
  if ($_64bit) { $num2=(($num2<<32)>>32); }   if ($_64bit) { $num2=(($num2<<32)>>32); }
  return "$num1:$num2";   return "$num1:$num2";
Line 6763  sub ireceipt { Line 6839  sub ireceipt {
     my $return =&recprefix($fucourseid).'-';      my $return =&recprefix($fucourseid).'-';
     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||      if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
  $env{'request.state'} eq 'construct') {   $env{'request.state'} eq 'construct') {
  &Apache::lonxml::debug("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname).   #&logthis("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname)." and ".($cpart%$cudom));
        " and ".($cpart%$cudom));  
                 
  $return.= ($cunique%$cuname+   $return.= ($cunique%$cuname+
    $cunique%$cudom+     $cunique%$cudom+
Line 6787  sub ireceipt { Line 6862  sub ireceipt {
   
 sub receipt {  sub receipt {
     my ($part)=@_;      my ($part)=@_;
     my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();      my ($symb,$courseid,$domain,$name) = &whichuser();
     return &ireceipt($name,$domain,$courseid,$symb,$part);      return &ireceipt($name,$domain,$courseid,$symb,$part);
 }  }
   
   sub whichuser {
       my ($passedsymb)=@_;
       my ($symb,$courseid,$domain,$name,$publicuser);
       if (defined($env{'form.grade_symb'})) {
    my ($tmp_courseid)=&get_env_multiple('form.grade_courseid');
    my $allowed=&allowed('vgr',$tmp_courseid);
    if (!$allowed &&
       exists($env{'request.course.sec'}) &&
       $env{'request.course.sec'} !~ /^\s*$/) {
       $allowed=&allowed('vgr',$tmp_courseid.
         '/'.$env{'request.course.sec'});
    }
    if ($allowed) {
       ($symb)=&get_env_multiple('form.grade_symb');
       $courseid=$tmp_courseid;
       ($domain)=&get_env_multiple('form.grade_domain');
       ($name)=&get_env_multiple('form.grade_username');
       return ($symb,$courseid,$domain,$name,$publicuser);
    }
       }
       if (!$passedsymb) {
    $symb=&symbread();
       } else {
    $symb=$passedsymb;
       }
       $courseid=$env{'request.course.id'};
       $domain=$env{'user.domain'};
       $name=$env{'user.name'};
       if ($name eq 'public' && $domain eq 'public') {
    if (!defined($env{'form.username'})) {
       $env{'form.username'}.=time.rand(10000000);
    }
    $name.=$env{'form.username'};
       }
       return ($symb,$courseid,$domain,$name,$publicuser);
   
   }
   
 # ------------------------------------------------------------ Serves up a file  # ------------------------------------------------------------ Serves up a file
 # returns either the contents of the file or   # returns either the contents of the file or 
 # -1 if the file doesn't exist  # -1 if the file doesn't exist
Line 7053  sub clutter { Line 7166  sub clutter {
     return $thisfn;      return $thisfn;
 }  }
   
   sub clutter_with_no_wrapper {
       my $uri = &clutter(shift);
       if ($uri =~ m-^/adm/-) {
    $uri =~ s-^/adm/wrapper/-/-;
    $uri =~ s-^/adm/coursedocs/showdoc/-/-;
       }
       return $uri;
   }
   
 sub freeze_escape {  sub freeze_escape {
     my ($value)=@_;      my ($value)=@_;
     if (ref($value)) {      if (ref($value)) {
Line 7189  sub get_iphost { Line 7311  sub get_iphost {
        chomp($configline);         chomp($configline);
        if ($configline) {         if ($configline) {
    my ($host,$type) = split(':',$configline,2);     my ($host,$type) = split(':',$configline,2);
    if ($type eq '') { $type = 'default' };     if (!defined($type) || $type eq '') { $type = 'default' };
    push(@{ $spareid{$type} }, $host);     push(@{ $spareid{$type} }, $host);
        }         }
     }      }
Line 7252  sub get_iphost { Line 7374  sub get_iphost {
   
 }  }
   
 $memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']});  $memcache=new Cache::Memcached({'servers'           => ['127.0.0.1:11211'],
    'compress_threshold'=> 20_000,
            });
   
 $processmarker='_'.time.'_'.$perlvar{'lonHostID'};  $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
 $dumpcount=0;  $dumpcount=0;
Line 7449  B<delenv($regexp)>: removes all items fr Line 7573  B<delenv($regexp)>: removes all items fr
 environment file that matches the regular expression in $regexp. The  environment file that matches the regular expression in $regexp. The
 values are also delted from the current processes %env.  values are also delted from the current processes %env.
   
   =item * get_env_multiple($name) 
   
   gets $name from the %env hash, it seemlessly handles the cases where multiple
   values may be defined and end up as an array ref.
   
   returns an array of values
   
 =back  =back
   
 =head2 User Information  =head2 User Information
Removed from v.1.784  
changed lines
  Added in v.1.799

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