[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.1256 and 1.1277

version 1.1256, 2014/04/23 10:11:34 version 1.1277, 2015/03/07 23:17:21
Line 961  sub has_user_session { Line 961  sub has_user_session {
 # --------- determine least loaded server in a user's domain which allows login  # --------- determine least loaded server in a user's domain which allows login
   
 sub choose_server {  sub choose_server {
     my ($udom,$checkloginvia,$required) = @_;      my ($udom,$checkloginvia,$required,$skiploadbal) = @_;
     my %domconfhash = &Apache::loncommon::get_domainconf($udom);      my %domconfhash = &Apache::loncommon::get_domainconf($udom);
     my %servers = &get_servers($udom);      my %servers = &get_servers($udom);
     my $lowest_load = 30000;      my $lowest_load = 30000;
     my ($login_host,$hostname,$portal_path,$isredirect);      my ($login_host,$hostname,$portal_path,$isredirect,$balancers);
       if ($skiploadbal) {
           ($balancers,my $cached)=&is_cached_new('loadbalancing',$udom);
           unless (defined($cached)) {
               my $cachetime = 60*60*24;
               my %domconfig =
                   &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);
               if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
                   $balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'},
                                              $cachetime);
               }
           }
       }
     foreach my $lonhost (keys(%servers)) {      foreach my $lonhost (keys(%servers)) {
           if ($skiploadbal) {
               if (ref($balancers) eq 'HASH') {
                   next if (exists($balancers->{$lonhost}));
               }
           }   
         my $loginvia;          my $loginvia;
         if ($checkloginvia) {          if ($checkloginvia) {
             $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};              $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
Line 1635  sub dump_dom { Line 1652  sub dump_dom {
   
 sub get_dom {  sub get_dom {
     my ($namespace,$storearr,$udom,$uhome)=@_;      my ($namespace,$storearr,$udom,$uhome)=@_;
       return if ($udom eq 'public');
     my $items='';      my $items='';
     foreach my $item (@$storearr) {      foreach my $item (@$storearr) {
         $items.=&escape($item).'&';          $items.=&escape($item).'&';
Line 1642  sub get_dom { Line 1660  sub get_dom {
     $items=~s/\&$//;      $items=~s/\&$//;
     if (!$udom) {      if (!$udom) {
         $udom=$env{'user.domain'};          $udom=$env{'user.domain'};
           return if ($udom eq 'public');
         if (defined(&domain($udom,'primary'))) {          if (defined(&domain($udom,'primary'))) {
             $uhome=&domain($udom,'primary');              $uhome=&domain($udom,'primary');
         } else {          } else {
Line 2011  sub get_domain_defaults { Line 2030  sub get_domain_defaults {
          &Apache::lonnet::get_dom('configuration',['defaults','quotas',           &Apache::lonnet::get_dom('configuration',['defaults','quotas',
                                   'requestcourses','inststatus',                                    'requestcourses','inststatus',
                                   'coursedefaults','usersessions',                                    'coursedefaults','usersessions',
                                   'requestauthor','selfenrollment'],$domain);                                    'requestauthor','selfenrollment',
                                     'coursecategories'],$domain);
     my @coursetypes = ('official','unofficial','community','textbook');      my @coursetypes = ('official','unofficial','community','textbook');
     if (ref($domconfig{'defaults'}) eq 'HASH') {      if (ref($domconfig{'defaults'}) eq 'HASH') {
         $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};           $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
Line 2056  sub get_domain_defaults { Line 2076  sub get_domain_defaults {
     }      }
     if (ref($domconfig{'coursedefaults'}) eq 'HASH') {      if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
         $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};          $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};
           $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};
           $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};
           if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {
               $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};
           }
         foreach my $type (@coursetypes) {          foreach my $type (@coursetypes) {
             if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {              if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
                 unless ($type eq 'community') {                  unless ($type eq 'community') {
Line 2065  sub get_domain_defaults { Line 2090  sub get_domain_defaults {
             if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {              if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
                 $domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};                  $domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};
             }              }
               if ($domdefaults{'postsubmit'} eq 'on') {
                   if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') {
                       $domdefaults{$type.'postsubtimeout'} = 
                           $domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type}; 
                   }
               }
         }          }
     }      }
     if (ref($domconfig{'usersessions'}) eq 'HASH') {      if (ref($domconfig{'usersessions'}) eq 'HASH') {
Line 2103  sub get_domain_defaults { Line 2134  sub get_domain_defaults {
             }              }
         }          }
     }      }
       if (ref($domconfig{'coursecategories'}) eq 'HASH') {
           $domdefaults{'catauth'} = 'std';
           $domdefaults{'catunauth'} = 'std';
           if ($domconfig{'coursecategories'}{'auth'}) { 
               $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'};
           }
           if ($domconfig{'coursecategories'}{'unauth'}) {
               $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};
           }
       }
     &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);      &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
     return %domdefaults;      return %domdefaults;
 }  }
Line 2693  sub ssi { Line 2734  sub ssi {
     &Apache::lonenc::check_encrypt(\$fn);      &Apache::lonenc::check_encrypt(\$fn);
     if (%form) {      if (%form) {
       $request=new HTTP::Request('POST',&absolute_url().$fn);        $request=new HTTP::Request('POST',&absolute_url().$fn);
       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form)));        $request->content(join('&',map { 
               my $name = escape($_);
               "$name=" . ( ref($form{$_}) eq 'ARRAY' 
               ? join("&$name=", map {escape($_) } @{$form{$_}}) 
               : &escape($form{$_}) );    
           } keys(%form)));
     } else {      } else {
       $request=new HTTP::Request('GET',&absolute_url().$fn);        $request=new HTTP::Request('GET',&absolute_url().$fn);
     }      }
Line 4823  sub tmprestore { Line 4869  sub tmprestore {
 # ----------------------------------------------------------------------- Store  # ----------------------------------------------------------------------- Store
   
 sub store {  sub store {
     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;      my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_;
     my $home='';      my $home='';
   
     if ($stuname) { $home=&homeserver($stuname,$domain); }      if ($stuname) { $home=&homeserver($stuname,$domain); }
Line 4853  sub store { Line 4899  sub store {
     }      }
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);      &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
     return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");      return reply("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home");
 }  }
   
 # -------------------------------------------------------------- Critical Store  # -------------------------------------------------------------- Critical Store
   
 sub cstore {  sub cstore {
     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;      my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_;
     my $home='';      my $home='';
   
     if ($stuname) { $home=&homeserver($stuname,$domain); }      if ($stuname) { $home=&homeserver($stuname,$domain); }
Line 4890  sub cstore { Line 4936  sub cstore {
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);      &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
     return critical      return critical
                 ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");                  ("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home");
 }  }
   
 # --------------------------------------------------------------------- Restore  # --------------------------------------------------------------------- Restore
Line 5070  sub privileged { Line 5116  sub privileged {
         my %rolesdump = &dump("roles", $domain, $username) or return 0;          my %rolesdump = &dump("roles", $domain, $username) or return 0;
         my $now = time;          my $now = time;
   
         for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {          for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys(%rolesdump)}) {
             my ($trole, $tend, $tstart) = split(/_/, $role);              my ($trole, $tend, $tstart) = split(/_/, $role);
             if (grep(/^\Q$trole\E$/,@{$roles})) {              if (grep(/^\Q$trole\E$/,@{$roles})) {
                 return 1 unless ($tend && $tend < $now)                   return 1 unless ($tend && $tend < $now) 
Line 5159  sub rolesinit { Line 5205  sub rolesinit {
     my %allroles=();      my %allroles=();
     my %allgroups=();      my %allgroups=();
   
     for my $area (grep { ! /^rolesdef_/ } keys %rolesdump) {      for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {
         my $role = $rolesdump{$area};          my $role = $rolesdump{$area};
         $area =~ s/\_\w\w$//;          $area =~ s/\_\w\w$//;
   
Line 5600  sub dump { Line 5646  sub dump {
     if (!$uname) { $uname=$env{'user.name'}; }      if (!$uname) { $uname=$env{'user.name'}; }
     my $uhome=&homeserver($uname,$udomain);      my $uhome=&homeserver($uname,$udomain);
   
     my $reply;      if ($regexp) {
           $regexp=&escape($regexp);
       } else {
           $regexp='.';
       }
     if (grep { $_ eq $uhome } current_machine_ids()) {      if (grep { $_ eq $uhome } current_machine_ids()) {
         # user is hosted on this machine          # user is hosted on this machine
         $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain,          my $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain,
                     $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});                      $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
         return %{unserialize($reply, $escapedkeys)};          return %{unserialize($reply, $escapedkeys)};
     }      }
     if ($regexp) {  
  $regexp=&escape($regexp);  
     } else {  
  $regexp='.';  
     }  
     my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);      my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
     my @pairs=split(/\&/,$rep);      my @pairs=split(/\&/,$rep);
     my %returnhash=();      my %returnhash=();
Line 5789  sub newput { Line 5834  sub newput {
 # ---------------------------------------------------------  putstore interface  # ---------------------------------------------------------  putstore interface
   
 sub putstore {  sub putstore {
    my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;     my ($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog)=@_;
    if (!$udomain) { $udomain=$env{'user.domain'}; }     if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$env{'user.name'}; }     if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
Line 5803  sub putstore { Line 5848  sub putstore {
    my $reply =     my $reply =
        &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",         &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
       $uhome);        $uhome);
      if (($tolog) && ($reply eq 'ok')) {
          my $namevalue='';
          foreach my $key (keys(%{$storehash})) {
              $namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&';
          }
          $namevalue .= 'ip='.&escape($ENV{'REMOTE_ADDR'}).
                        '&host='.&escape($perlvar{'lonHostID'}).
                        '&version='.$esc_v.
                        '&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});
          &Apache::lonnet::courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue);
      }
    if ($reply eq 'unknown_cmd') {     if ($reply eq 'unknown_cmd') {
        # gfall back to way things use to be done         # gfall back to way things use to be done
        return &old_putstore($namespace,$symb,$version,$storehash,$udomain,         return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
Line 5961  sub get_timebased_id { Line 6017  sub get_timebased_id {
         my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix);          my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix);
         my $id = time;          my $id = time;
         $newid = $id;          $newid = $id;
           if ($idtype eq 'addcode') {
               $newid .= &sixnum_code();
           }
         my $idtries = 0;          my $idtries = 0;
         while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) {          while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) {
             if ($idtype eq 'concat') {              if ($idtype eq 'concat') {
                 $newid = $id.$idtries;                  $newid = $id.$idtries;
               } elsif ($idtype eq 'addcode') {
                   $newid = $newid.&sixnum_code();
             } else {              } else {
                 $newid ++;                  $newid ++;
             }              }
Line 5981  sub get_timebased_id { Line 6042  sub get_timebased_id {
                 $error = 'error saving new item: '.$putresult;                  $error = 'error saving new item: '.$putresult;
             }              }
         } else {          } else {
                undef($newid);
              $error = ('error: no unique suffix available for the new item ');               $error = ('error: no unique suffix available for the new item ');
         }          }
 #  remove lock  #  remove lock
Line 5989  sub get_timebased_id { Line 6051  sub get_timebased_id {
     } else {      } else {
         $error = "error: could not obtain lockfile\n";          $error = "error: could not obtain lockfile\n";
         $dellock = 'ok';          $dellock = 'ok';
           if (($prefix eq 'paste') && ($namespace eq 'courseeditor') && ($keyid eq 'num')) {
               $dellock = 'nolock';
           }
     }      }
     return ($newid,$dellock,$error);      return ($newid,$dellock,$error);
 }  }
   
   sub sixnum_code {
       my $code;
       for (0..6) {
           $code .= int( rand(9) );
       }
       return $code;
   }
   
 # -------------------------------------------------- portfolio access checking  # -------------------------------------------------- portfolio access checking
   
 sub portfolio_access {  sub portfolio_access {
     my ($requrl) = @_;      my ($requrl,$clientip) = @_;
     my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);      my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
     my $result = &get_portfolio_access($udom,$unum,$file_name,$group);      my $result = &get_portfolio_access($udom,$unum,$file_name,$group,$clientip);
     if ($result) {      if ($result) {
         my %setters;          my %setters;
         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {          if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
Line 6024  sub portfolio_access { Line 6097  sub portfolio_access {
 }  }
   
 sub get_portfolio_access {  sub get_portfolio_access {
     my ($udom,$unum,$file_name,$group,$access_hash) = @_;      my ($udom,$unum,$file_name,$group,$clientip,$access_hash) = @_;
   
     if (!ref($access_hash)) {      if (!ref($access_hash)) {
  my $current_perms = &get_portfile_permissions($udom,$unum);   my $current_perms = &get_portfile_permissions($udom,$unum);
Line 6033  sub get_portfolio_access { Line 6106  sub get_portfolio_access {
  $access_hash = $access_controls{$file_name};   $access_hash = $access_controls{$file_name};
     }      }
   
     my ($public,$guest,@domains,@users,@courses,@groups);      my ($public,$guest,@domains,@users,@courses,@groups,@ips);
     my $now = time;      my $now = time;
     if (ref($access_hash) eq 'HASH') {      if (ref($access_hash) eq 'HASH') {
         foreach my $key (keys(%{$access_hash})) {          foreach my $key (keys(%{$access_hash})) {
Line 6057  sub get_portfolio_access { Line 6130  sub get_portfolio_access {
                 push(@courses,$key);                  push(@courses,$key);
             } elsif ($scope eq 'group') {              } elsif ($scope eq 'group') {
                 push(@groups,$key);                  push(@groups,$key);
               } elsif ($scope eq 'ip') {
                   push(@ips,$key);
             }              }
         }          }
         if ($public) {          if ($public) {
             return 'ok';              return 'ok';
           } elsif (@ips > 0) {
               my $allowed;
               foreach my $ipkey (@ips) {
                   if (ref($access_hash->{$ipkey}{'ip'}) eq 'ARRAY') {
                       if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$ipkey}{'ip'}}),$clientip)) {
                           $allowed = 1;
                           last; 
                       }
                   }
               }
               if ($allowed) {
                   return 'ok';
               }
         }          }
         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {          if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
             if ($guest) {              if ($guest) {
Line 6544  sub customaccess { Line 6632  sub customaccess {
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri,$symb,$role)=@_;      my ($priv,$uri,$symb,$role,$clientip)=@_;
     my $ver_orguri=$uri;      my $ver_orguri=$uri;
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
Line 6771  sub allowed { Line 6859  sub allowed {
  && $thisallowed ne 'F'    && $thisallowed ne 'F' 
  && $thisallowed ne '2'   && $thisallowed ne '2'
  && &is_portfolio_url($uri)) {   && &is_portfolio_url($uri)) {
  $thisallowed = &portfolio_access($uri);   $thisallowed = &portfolio_access($uri,$clientip);
     }      }
   
 # Full access at system, domain or course-wide level? Exit.  # Full access at system, domain or course-wide level? Exit.
Line 7893  sub auto_validate_class_sec { Line 7981  sub auto_validate_class_sec {
   
 sub auto_crsreq_update {  sub auto_crsreq_update {
     my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,      my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,
         $code,$inbound) = @_;          $code,$accessstart,$accessend,$inbound) = @_;
     my ($homeserver,%crsreqresponse);      my ($homeserver,%crsreqresponse);
     if ($cdom =~ /^$match_domain$/) {      if ($cdom =~ /^$match_domain$/) {
         $homeserver = &domain($cdom,'primary');          $homeserver = &domain($cdom,'primary');
Line 7906  sub auto_crsreq_update { Line 7994  sub auto_crsreq_update {
         my $response=&reply('autocrsrequpdate:'.$cdom.':'.$cnum.':'.&escape($crstype).          my $response=&reply('autocrsrequpdate:'.$cdom.':'.$cnum.':'.&escape($crstype).
                             ':'.&escape($action).':'.&escape($ownername).':'.                              ':'.&escape($action).':'.&escape($ownername).':'.
                             &escape($ownerdomain).':'.&escape($fullname).':'.                              &escape($ownerdomain).':'.&escape($fullname).':'.
                             &escape($title).':'.&escape($code).':'.$info,$homeserver);                              &escape($title).':'.&escape($code).':'.
                               &escape($accessstart).':'.&escape($accessend).':'.$info,
                               $homeserver);
         unless ($response =~ /(con_lost|error|no_such_host|refused)/) {          unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
             my @items = split(/&/,$response);              my @items = split(/&/,$response);
             foreach my $item (@items) {              foreach my $item (@items) {
Line 9084  sub files_not_in_path { Line 9174  sub files_not_in_path {
     return (@return_files);      return (@return_files);
 }  }
   
   #------------------------------Submitted/Handedback Portfolio Files Versioning
    
   sub portfiles_versioning {
       my ($symb,$domain,$stu_name,$portfiles,$versioned_portfiles) = @_;
       my $portfolio_root = '/userfiles/portfolio';
       return unless ((ref($portfiles) eq 'ARRAY') && (ref($versioned_portfiles) eq 'ARRAY'));
       foreach my $file (@{$portfiles}) {
           &unmark_as_readonly($domain,$stu_name,[$symb,$env{'request.course.id'}],$file);
           my ($directory,$answer_file) =($file =~ /^(.*?)([^\/]*)$/);
           my ($answer_name,$answer_ver,$answer_ext) = &file_name_version_ext($answer_file);
           my $getpropath = 1;
           my ($dir_list,$listerror) = &dirlist($portfolio_root.$directory,$domain,
                                                $stu_name,$getpropath);
           my $version = &get_next_version($answer_name,$answer_ext,$dir_list);
           my $new_answer = 
               &version_selected_portfile($domain,$stu_name,$directory,$answer_file,$version);
           if ($new_answer ne 'problem getting file') {
               push(@{$versioned_portfiles}, $directory.$new_answer);
               &mark_as_readonly($domain,$stu_name,[$directory.$new_answer],
                                 [$symb,$env{'request.course.id'},'graded']);
           }
       }
   }
   
   sub get_next_version {
       my ($answer_name, $answer_ext, $dir_list) = @_;
       my $version;
       if (ref($dir_list) eq 'ARRAY') {
           foreach my $row (@{$dir_list}) {
               my ($file) = split(/\&/,$row,2);
               my ($file_name,$file_version,$file_ext) =
                   &file_name_version_ext($file);
               if (($file_name eq $answer_name) &&
                   ($file_ext eq $answer_ext)) {
                        # gets here if filename and extension match,
                        # regardless of version
                   if ($file_version ne '') {
                       # a versioned file is found  so save it for later
                       if ($file_version > $version) {
                           $version = $file_version;
                       }
                   }
               }
           }
       }
       $version ++;
       return($version);
   }
   
   sub version_selected_portfile {
       my ($domain,$stu_name,$directory,$file_name,$version) = @_;
       my ($answer_name,$answer_ver,$answer_ext) =
           &file_name_version_ext($file_name);
       my $new_answer;
       $env{'form.copy'} =
           &getfile("/uploaded/$domain/$stu_name/portfolio$directory$file_name");
       if($env{'form.copy'} eq '-1') {
           $new_answer = 'problem getting file';
       } else {
           $new_answer = $answer_name.'.'.$version.'.'.$answer_ext;
           my $copy_result = 
               &finishuserfileupload($stu_name,$domain,'copy',
                                     '/portfolio'.$directory.$new_answer);
       }
       undef($env{'form.copy'});
       return ($new_answer);
   }
   
   sub file_name_version_ext {
       my ($file)=@_;
       my @file_parts = split(/\./, $file);
       my ($name,$version,$ext);
       if (@file_parts > 1) {
           $ext=pop(@file_parts);
           if (@file_parts > 1 && $file_parts[-1] =~ /^\d+$/) {
               $version=pop(@file_parts);
           }
           $name=join('.',@file_parts);
       } else {
           $name=join('.',@file_parts);
       }
       return($name,$version,$ext);
   }
   
 #----------------------------------------------Get portfolio file permissions  #----------------------------------------------Get portfolio file permissions
   
 sub get_portfile_permissions {  sub get_portfile_permissions {
Line 9228  sub modify_access_controls { Line 9402  sub modify_access_controls {
 }  }
   
 sub make_public_indefinitely {  sub make_public_indefinitely {
     my ($requrl) = @_;      my (@requrl) = @_;
       return &automated_portfile_access('public',\@requrl);
   }
   
   sub automated_portfile_access {
       my ($accesstype,$addsref,$delsref,$info) = @_;
       unless (($accesstype eq 'public') || ($accesstype eq 'ip')) {
           return 'invalid';
       }
       my %urls;
       if (ref($addsref) eq 'ARRAY') {
           foreach my $requrl (@{$addsref}) {
               if (&is_portfolio_url($requrl)) {
                   unless (exists($urls{$requrl})) {
                       $urls{$requrl} = 'add';
                   }
               }
           }
       }
       if (ref($delsref) eq 'ARRAY') {
           foreach my $requrl (@{$delsref}) { 
               if (&is_portfolio_url($requrl)) {
                   unless (exists($urls{$requrl})) {
                       $urls{$requrl} = 'delete'; 
                   }
               }
           }
       }
       unless (keys(%urls)) {
           return 'invalid';
       }
       my $ip;
       if ($accesstype eq 'ip') {
           if (ref($info) eq 'HASH') {
               if ($info->{'ip'} ne '') {
                   $ip = $info->{'ip'};
               }
           }
           if ($ip eq '') {
               return 'invalid';
           }
       }
       my $errors;
     my $now = time;      my $now = time;
     my $action = 'activate';      my %current_perms;
     my $aclnum = 0;      foreach my $requrl (sort(keys(%urls))) {
     if (&is_portfolio_url($requrl)) {          my $action;
           if ($urls{$requrl} eq 'add') {
               $action = 'activate';
           } else {
               $action = 'none';
           }
           my $aclnum = 0;
         my (undef,$udom,$unum,$file_name,$group) =          my (undef,$udom,$unum,$file_name,$group) =
             &parse_portfolio_url($requrl);              &parse_portfolio_url($requrl);
         my $current_perms = &get_portfile_permissions($udom,$unum);          unless (exists($current_perms{$unum.':'.$udom})) {
         my %access_controls = &get_access_controls($current_perms,              $current_perms{$unum.':'.$udom} = &get_portfile_permissions($udom,$unum);
           }
           my %access_controls = &get_access_controls($current_perms{$unum.':'.$udom},
                                                    $group,$file_name);                                                     $group,$file_name);
         foreach my $key (keys(%{$access_controls{$file_name}})) {          foreach my $key (keys(%{$access_controls{$file_name}})) {
             my ($num,$scope,$end,$start) =               my ($num,$scope,$end,$start) = 
                 ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);                  ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
             if ($scope eq 'public') {              if ($scope eq $accesstype) {
                 if ($start <= $now && $end == 0) {                  if (($start <= $now) && ($end == 0)) {
                     $action = 'none';                      if ($accesstype eq 'ip') {
                 } else {                          if (ref($access_controls{$file_name}{$key}) eq 'HASH') {
                               if (ref($access_controls{$file_name}{$key}{'ip'}) eq 'ARRAY') {
                                   if (grep(/^\Q$ip\E$/,@{$access_controls{$file_name}{$key}{'ip'}})) {
                                       if ($urls{$requrl} eq 'add') {
                                           $action = 'none';
                                           last;
                                       } else {
                                           $action = 'delete';
                                           $aclnum = $num;
                                           last;
                                       }
                                   }
                               }
                           }
                       } elsif ($accesstype eq 'public') {
                           if ($urls{$requrl} eq 'add') {
                               $action = 'none';
                               last;
                           } else {
                               $action = 'delete';
                               $aclnum = $num;
                               last;
                           }
                       }
                   } elsif ($accesstype eq 'public') {
                     $action = 'update';                      $action = 'update';
                     $aclnum = $num;                      $aclnum = $num;
                       last;
                 }                  }
                 last;  
             }              }
         }          }
         if ($action eq 'none') {          if ($action eq 'none') {
              return 'ok';              next;
         } else {          } else {
             my %changes;              my %changes;
             my $newend = 0;              my $newend = 0;
             my $newstart = $now;              my $newstart = $now;
             my $newkey = $aclnum.':public_'.$newend.'_'.$newstart;              my $newkey = $aclnum.':'.$accesstype.'_'.$newend.'_'.$newstart;
             $changes{$action}{$newkey} = {              $changes{$action}{$newkey} = {
                 type => 'public',                  type => $accesstype,
                 time => {                  time => {
                     start => $newstart,                      start => $newstart,
                     end   => $newend,                      end   => $newend,
                 },                  },
             };              };
               if ($accesstype eq 'ip') {
                   $changes{$action}{$newkey}{'ip'} = [$ip];
               }
             my ($outcome,$deloutcome,$new_values,$translation) =              my ($outcome,$deloutcome,$new_values,$translation) =
                 &modify_access_controls($file_name,\%changes,$udom,$unum);                  &modify_access_controls($file_name,\%changes,$udom,$unum);
             return $outcome;              unless ($outcome eq 'ok') {
                   $errors .= $outcome.' ';
               }
         }          }
       }
       if ($errors) {
           $errors =~ s/\s$//;
           return $errors;
     } else {      } else {
         return 'invalid';          return 'ok';
     }      }
 }  }
   
Line 10193  sub metadata { Line 10450  sub metadata {
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
  return undef;   return undef;
     }      }
     if (($uri =~ /^priv/ || $uri=~/home\/httpd\/html\/priv/)       if (($uri =~ /^priv/ || $uri=~m{^home/httpd/html/priv}) 
  && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {   && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {
  return undef;   return undef;
     }      }
Line 10454  sub metadata { Line 10711  sub metadata {
   
  $metaentry{':keys'} = join(',',keys(%metathesekeys));   $metaentry{':keys'} = join(',',keys(%metathesekeys));
  &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);   &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
  $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);   $metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys));
  &do_cache_new('meta',$uri,\%metaentry,$cachetime);   &do_cache_new('meta',$uri,\%metaentry,$cachetime);
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
Line 10826  sub deversion { Line 11083  sub deversion {
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse)=@_;      my ($thisfn,$donotrecurse)=@_;
     my $cache_str;      my $cache_str='request.symbread.cached.'.$thisfn;
     if ($thisfn ne '') {      if (defined($env{$cache_str})) { return $env{$cache_str}; }
         $cache_str='request.symbread.cached.'.$thisfn;  
         if ($env{$cache_str} ne '') {  
             return $env{$cache_str};  
         }  
     } else {  
 # no filename provided? try from environment  # no filename provided? try from environment
       unless ($thisfn) {
         if ($env{'request.symb'}) {          if ($env{'request.symb'}) {
     return $env{$cache_str}=&symbclean($env{'request.symb'});      return $env{$cache_str}=&symbclean($env{'request.symb'});
  }   }
Line 11251  sub rndseed_CODE_64bit5 { Line 11504  sub rndseed_CODE_64bit5 {
 sub setup_random_from_rndseed {  sub setup_random_from_rndseed {
     my ($rndseed)=@_;      my ($rndseed)=@_;
     if ($rndseed =~/([,:])/) {      if ($rndseed =~/([,:])/) {
  my ($num1,$num2)=split(/[,:]/,$rndseed);          my ($num1,$num2) = map { abs($_); } (split(/[,:]/,$rndseed));
  &Math::Random::random_set_seed(abs($num1),abs($num2));          if ((!$num1) || (!$num2) || ($num1 > 2147483562) || ($num2 > 2147483398)) {
               &Math::Random::random_set_seed_from_phrase($rndseed);
           } else {
               &Math::Random::random_set_seed($num1,$num2);
           }
     } else {      } else {
  &Math::Random::random_set_seed_from_phrase($rndseed);   &Math::Random::random_set_seed_from_phrase($rndseed);
     }      }
Line 11643  sub default_login_domain { Line 11900  sub default_login_domain {
 sub declutter {  sub declutter {
     my $thisfn=shift;      my $thisfn=shift;
     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }      if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
     $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;      unless ($thisfn=~m{^/home/httpd/html/priv/}) {
           $thisfn=~s{^/home/httpd/html}{};
       }
     $thisfn=~s/^\///;      $thisfn=~s/^\///;
     $thisfn=~s|^adm/wrapper/||;      $thisfn=~s|^adm/wrapper/||;
     $thisfn=~s|^adm/coursedocs/showdoc/||;      $thisfn=~s|^adm/coursedocs/showdoc/||;
Line 11770  sub get_dns { Line 12029  sub get_dns {
  $alldns{$host} = $protocol;   $alldns{$host} = $protocol;
     }      }
     while (%alldns) {      while (%alldns) {
  my ($dns) = keys(%alldns);   my ($dns) = sort { $b cmp $a } keys(%alldns);
  my $ua=new LWP::UserAgent;   my $ua=new LWP::UserAgent;
         $ua->timeout(30);          $ua->timeout(30);
  my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");   my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
Line 11796  sub get_dns { Line 12055  sub get_dns {
 # ------------------------------------------------------Get DNS checksums file  # ------------------------------------------------------Get DNS checksums file
 sub parse_dns_checksums_tab {  sub parse_dns_checksums_tab {
     my ($lines,$hashref) = @_;      my ($lines,$hashref) = @_;
     my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});      my $lonhost = $perlvar{'lonHostID'};
       my $machine_dom = &Apache::lonnet::host_domain($lonhost);
     my $loncaparev = &get_server_loncaparev($machine_dom);      my $loncaparev = &get_server_loncaparev($machine_dom);
       my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];
       my $webconfdir = '/etc/httpd/conf';
       if ($distro =~ /^(ubuntu|debian)(\d+)$/) {
           $webconfdir = '/etc/apache2';
       } elsif ($distro =~ /^sles(\d+)$/) {
           if ($1 >= 10) {
               $webconfdir = '/etc/apache2';
           }
       } elsif ($distro =~ /^suse(\d+\.\d+)$/) {
           if ($1 >= 10.0) {
               $webconfdir = '/etc/apache2';
           }
       }
     my ($release,$timestamp) = split(/\-/,$loncaparev);      my ($release,$timestamp) = split(/\-/,$loncaparev);
     my (%chksum,%revnum);      my (%chksum,%revnum);
     if (ref($lines) eq 'ARRAY') {      if (ref($lines) eq 'ARRAY') {
Line 11806  sub parse_dns_checksums_tab { Line 12079  sub parse_dns_checksums_tab {
         if ($version eq $release) {            if ($version eq $release) {  
             foreach my $line (@{$lines}) {              foreach my $line (@{$lines}) {
                 my ($file,$version,$shasum) = split(/,/,$line);                  my ($file,$version,$shasum) = split(/,/,$line);
                   if ($file =~ m{^/etc/httpd/conf}) {
                       if ($webconfdir eq '/etc/apache2') {
                           $file =~ s{^\Q/etc/httpd/conf/\E}{$webconfdir/};
                       }
                   }
                 $chksum{$file} = $shasum;                  $chksum{$file} = $shasum;
                 $revnum{$file} = $version;                  $revnum{$file} = $version;
             }              }
Line 11823  sub parse_dns_checksums_tab { Line 12101  sub parse_dns_checksums_tab {
 sub fetch_dns_checksums {  sub fetch_dns_checksums {
     my %checksums;      my %checksums;
     my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});      my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
     my $loncaparev = &get_server_loncaparev($machine_dom);      my $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'});
     my ($release,$timestamp) = split(/\-/,$loncaparev);      my ($release,$timestamp) = split(/\-/,$loncaparev);
     &get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,      &get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,
              \%checksums);               \%checksums);
Line 12522  were new keys. I.E. 1:foo will become 1: Line 12800  were new keys. I.E. 1:foo will become 1:
 Calling convention:  Calling convention:
   
  my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname);   my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname);
  &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname);   &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$laststore);
   
 For more detailed information, see lonnet specific documentation.  For more detailed information, see lonnet specific documentation.
   
Line 13159  homeserver. Line 13437  homeserver.
   
 =item *  =item *
   
 store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently  store($storehash,$symb,$namespace,$udom,$uname,$laststore) : stores hash
 for this url; hashref needs to be given and should be a \%hashname; the  permanently for this url; hashref needs to be given and should be a \%hashname;
 remaining args aren't required and if they aren't passed or are '' they will  the remaining args aren't required and if they aren't passed or are '' they will
 be derived from the env  be derived from the env (with the exception of $laststore, which is an 
   optional arg used when a user's submission is stored in grading).
   $laststore is $version=$timestamp, where $version is the most recent version
   number retrieved for the corresponding $symb in the $namespace db file, and
   $timestamp is the timestamp for that transaction (UNIX time).
   $laststore is currently only passed when cstore() is called by 
   structuretags::finalize_storage().
   
 =item *  =item *
   
 cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but  cstore($storehash,$symb,$namespace,$udom,$uname,$laststore) : same as store
 uses critical subroutine  but uses critical subroutine
   
 =item *  =item *
   
Line 13190  $range should be either an integer '100' Line 13474  $range should be either an integer '100'
   
 =item *  =item *
   
 putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :  putstore($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog) :
 replaces a &store() version of data with a replacement set of data  replaces a &store() version of data with a replacement set of data
 for a particular resource in a namespace passed in the $storehash hash   for a particular resource in a namespace passed in the $storehash hash 
 reference  reference. If $tolog is true, the transaction is logged in the courselog
   with an action=PUTSTORE.
   
 =item *  =item *
   
Line 13612  filelocation except for hrefs Line 13897  filelocation except for hrefs
   
 =item *  =item *
   
 declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)  declutter() : declutters URLs -- remove beginning slashes, 'res' etc.
   also removes beginning /home/httpd/html unless /priv/ follows it.
   
 =back  =back
   
Removed from v.1.1256  
changed lines
  Added in v.1.1277

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