[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.1512 and 1.1537

version 1.1512, 2023/06/20 14:03:57 version 1.1537, 2025/03/19 14:44:04
Line 188  sub create_connection { Line 188  sub create_connection {
      Type    => SOCK_STREAM,       Type    => SOCK_STREAM,
      Timeout => 10);       Timeout => 10);
     return 0 if (!$client);      return 0 if (!$client);
     print $client (join(':',$hostname,$lonid,&machine_ids($hostname),$loncaparevs{$lonid})."\n");      if ($loncaparevs{$lonid} =~ /^(\d+\.\d+\.[\w.]+)-\d+$/) {
           print $client (join(':',$hostname,$lonid,$1,&machine_ids($hostname))."\n");
       } else {
           print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n");
       }
     my $result = <$client>;      my $result = <$client>;
     chomp($result);      chomp($result);
     return 1 if ($result eq 'done');      return 1 if ($result eq 'done');
Line 224  sub get_server_distarch { Line 228  sub get_server_distarch {
             }              }
         }          }
         my $rep = &reply('serverdistarch',$lonhost);          my $rep = &reply('serverdistarch',$lonhost);
         unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' ||          unless ($rep eq 'unknown_cmd' || $rep eq 'no_such_host' ||
                 $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||                  $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||
                 $rep eq '') {                  $rep eq '') {
             return &do_cache_new('serverdistarch',$lonhost,$rep,$cachetime);              return &do_cache_new('serverdistarch',$lonhost,$rep,$cachetime);
Line 2753  sub get_domain_defaults { Line 2757  sub get_domain_defaults {
          &get_dom('configuration',['defaults','quotas',           &get_dom('configuration',['defaults','quotas',
                                   'requestcourses','inststatus',                                    'requestcourses','inststatus',
                                   'coursedefaults','usersessions',                                    'coursedefaults','usersessions',
                                   'requestauthor','selfenrollment',                                    'requestauthor','authordefaults',
                                   'coursecategories','ssl','autoenroll',                                    'selfenrollment','coursecategories',
                                   'trust','helpsettings','wafproxy',                                    'ssl','autoenroll','trust',
                                   'ltisec','toolsec','domexttool',                                    'helpsettings','wafproxy',
                                   'exttool','privacy'],$domain);                                    'ltisec','toolsec','privacy'],$domain);
     my @coursetypes = ('official','unofficial','community','textbook','placement');      my @coursetypes = ('official','unofficial','community','textbook','placement');
     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 2783  sub get_domain_defaults { Line 2787  sub get_domain_defaults {
         } else {          } else {
             $domdefaults{'defaultquota'} = $domconfig{'quotas'};              $domdefaults{'defaultquota'} = $domconfig{'quotas'};
         }          }
         my @usertools = ('aboutme','blog','webdav','portfolio');          my @usertools = ('aboutme','blog','webdav','portfolio','portaccess');
         foreach my $item (@usertools) {          foreach my $item (@usertools) {
             if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {              if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
                 $domdefaults{$item} = $domconfig{'quotas'}{$item};                  $domdefaults{$item} = $domconfig{'quotas'}{$item};
Line 2801  sub get_domain_defaults { Line 2805  sub get_domain_defaults {
     if (ref($domconfig{'requestauthor'}) eq 'HASH') {      if (ref($domconfig{'requestauthor'}) eq 'HASH') {
         $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};          $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};
     }      }
       if (ref($domconfig{'authordefaults'}) eq 'HASH') {
           foreach my $item ('nocodemirror','copyright','sourceavail','domcoordacc','editors','archive') {
               if ($item eq 'editors') {
                   if (ref($domconfig{'authordefaults'}{'editors'}) eq 'ARRAY') {
                       $domdefaults{$item} = join(',',@{$domconfig{'authordefaults'}{'editors'}});
                   }
               } else {
                   $domdefaults{$item} = $domconfig{'authordefaults'}{$item};
               }
           }
       }
     if (ref($domconfig{'inststatus'}) eq 'HASH') {      if (ref($domconfig{'inststatus'}) eq 'HASH') {
         foreach my $item ('inststatustypes','inststatusorder','inststatusguest') {          foreach my $item ('inststatustypes','inststatusorder','inststatusguest') {
             $domdefaults{$item} = $domconfig{'inststatus'}{$item};              $domdefaults{$item} = $domconfig{'inststatus'}{$item};
Line 2814  sub get_domain_defaults { Line 2829  sub get_domain_defaults {
         if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {          if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {
             $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};              $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};
         }          }
           if (ref($domconfig{'coursedefaults'}{'crseditors'}) eq 'ARRAY') {
               $domdefaults{'crseditors'}=join(',',@{$domconfig{'coursedefaults'}{'crseditors'}});
           }
         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 2823  sub get_domain_defaults { Line 2841  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 (ref($domconfig{'coursedefaults'}{'coursequota'}) eq 'HASH') {
                   $domdefaults{$type.'coursequota'} = $domconfig{'coursedefaults'}{'coursequota'}{$type};
               }
             if ($domdefaults{'postsubmit'} eq 'on') {              if ($domdefaults{'postsubmit'} eq 'on') {
                 if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') {                  if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') {
                     $domdefaults{$type.'postsubtimeout'} =                       $domdefaults{$type.'postsubtimeout'} = 
Line 2839  sub get_domain_defaults { Line 2860  sub get_domain_defaults {
             } else {              } else {
                 $domdefaults{$type.'exttool'} = 0;                  $domdefaults{$type.'exttool'} = 0;
             }              }
               if (ref($domconfig{'coursedefaults'}{'crsauthor'}) eq 'HASH') {
                   $domdefaults{$type.'crsauthor'} = $domconfig{'coursedefaults'}{'crsauthor'}{$type};
               } else {
                   $domdefaults{$type.'crsauthor'} = 1;
               }
         }          }
         if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') {          if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') {
             if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') {              if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') {
Line 2956  sub get_domain_defaults { Line 2982  sub get_domain_defaults {
                 $domdefaults{'ltiprivhosts'} = $domconfig{'ltisec'}{'private'}{'keys'};                  $domdefaults{'ltiprivhosts'} = $domconfig{'ltisec'}{'private'}{'keys'};
             }              }
         }          }
           if (ref($domconfig{'ltisec'}{'suggested'}) eq 'HASH') {
               my %suggestions = %{$domconfig{'ltisec'}{'suggested'}};
               foreach my $item (keys(%{$domconfig{'ltisec'}{'suggested'}})) {
                   unless (ref($domconfig{'ltisec'}{'suggested'}{$item}) eq 'HASH') {
                       delete($suggestions{$item});
                   }
               }
               if (keys(%suggestions)) {
                   $domdefaults{'linkprotsuggested'} = \%suggestions;
               }
           }
     }      }
     if (ref($domconfig{'toolsec'}) eq 'HASH') {      if (ref($domconfig{'toolsec'}) eq 'HASH') {
         if (ref($domconfig{'toolsec'}{'encrypt'}) eq 'HASH') {          if (ref($domconfig{'toolsec'}{'encrypt'}) eq 'HASH') {
Line 2982  sub get_domain_defaults { Line 3019  sub get_domain_defaults {
                 last if ($domdefaults{'userapprovals'});                  last if ($domdefaults{'userapprovals'});
             }              }
         }          }
           if (ref($domconfig{'privacy'}{'othdom'}) eq 'HASH') {
               $domdefaults{'privacyothdom'} = $domconfig{'privacy'}{'othdom'};
           }
     }      }
     &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);      &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
     return %domdefaults;      return %domdefaults;
Line 3694  sub ssi_body { Line 3734  sub ssi_body {
     $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;      $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
     $output=~s/^.*?\<body[^\>]*\>//si;      $output=~s/^.*?\<body[^\>]*\>//si;
     $output=~s/\<\/body\s*\>.*?$//si;      $output=~s/\<\/body\s*\>.*?$//si;
       $output=~s{\Q<div class="LC_landmark" role="main">\E}{<div>}gs;
     if (wantarray) {      if (wantarray) {
         return ($output, $response);          return ($output, $response);
     } else {      } else {
Line 3918  sub can_edit_resource { Line 3959  sub can_edit_resource {
         }          }
     }      }
   
   #
   # For /adm/viewcoauthors can only edit if author or co-author who is manager.
   #
   
       if (($resurl eq '/adm/viewcoauthors') && ($cnum ne '') && ($cdom ne '')) {
           if (((&allowed('cca',"$cdom/$cnum")) ||
                (&allowed('caa',"$cdom/$cnum"))) ||
                ((&allowed('vca',"$cdom/$cnum") ||
                  &allowed('vaa',"$cdom/$cnum")) &&
                 ($env{"environment.internal.manager./$cdom/$cnum"}))) {
               $home = $env{'user.home'};
               $cfile = $resurl;
               if ($env{'form.forceedit'}) {
                   $forceview = 1;
               } else {
                   $forceedit = 1;
               }
               return ($cfile,$home,$switchserver,$forceedit,$forceview);
           } else {
               return;
           }
       }
   
     if ($env{'request.course.id'}) {      if ($env{'request.course.id'}) {
         my $crsedit = &allowed('mdc',$env{'request.course.id'});          my $crsedit = &allowed('mdc',$env{'request.course.id'});
         if ($group ne '') {          if ($group ne '') {
Line 5468  sub courserolelog { Line 5532  sub courserolelog {
             $storehash{'group'} = $sec;              $storehash{'group'} = $sec;
         } else {          } else {
             $storehash{'section'} = $sec;              $storehash{'section'} = $sec;
               my ($curruserdomstr,$newuserdomstr);
               if (exists($env{'course.'.$cdom.'_'.$cnum.'.internal.userdomains'})) {
                   $curruserdomstr = $env{'course.'.$env{'request.course.id'}.'.internal.userdomains'};
               } else {
                   my %courseinfo = &coursedescription($cdom.'/'.$cnum);
                   $curruserdomstr = $courseinfo{'internal.userdomains'};
               }
               if ($curruserdomstr ne '') {
                   my @udoms = split(/,/,$curruserdomstr);
                   unless (grep(/^\Q$domain\E/,@udoms)) {
                       push(@udoms,$domain);
                       $newuserdomstr = join(',',sort(@udoms));
                   }
               } else {
                   $newuserdomstr = $domain;
               }
               if ($newuserdomstr ne '') {
                   my $putresult = &put('environment',{ 'internal.userdomains' => $newuserdomstr },
                                        $cdom,$cnum);
                   if ($putresult eq 'ok') {
                       unless (($selfenroll) || ($context eq 'selfenroll')) { 
                           if (($context eq 'createcourse') || ($context eq 'requestcourses') ||
                               ($context eq 'automated') || ($context eq 'domain')) {
                               $env{'course.'.$cdom.'_'.$cnum.'.internal.userdomains'} = $newuserdomstr;
                           } elsif ($env{'request.course.id'} eq $cdom.'_'.$cnum) {
                               &appenv({'course.'.$cdom.'_'.$cnum.'.internal.userdomains' => $newuserdomstr});
                           }
                       }
                   }
               }
         }          }
         &write_log('course',$namespace,\%storehash,$delflag,$username,          &write_log('course',$namespace,\%storehash,$delflag,$username,
                    $domain,$cnum,$cdom);                     $domain,$cnum,$cdom);
Line 5537  sub coauthorrolelog { Line 5631  sub coauthorrolelog {
     return;      return;
 }  }
   
   sub authorarchivelog {
       my ($hashref,$size,$filesdest,$action) = @_;
       my $lonprtdir = $Apache::lonnet::perlvar{'lonPrtDir'};
       my $londocroot = $Apache::lonnet::perlvar{'lonDocRoot'};
       $filesdest =~ s{^\Q$lonprtdir/\E}{};
       if ($filesdest =~ m{^($match_username)_($match_domain)_archive_(\d+_\d+_\d+(|[.\w]+))$}) {
           my ($auname,$audom,$id) = ($1,$2,$3);
           if (ref($hashref) eq 'HASH') {
               my $namespace = 'archivelog';
               my $dir;
               if ($hashref->{dir} =~ m{^\Q$londocroot/priv/$audom/$auname\E(.*)$}) {
                   $dir = $1;
               }
               my $delflag = 0;
               my %storehash = (
                                 id      => $id,
                                 dir     => $dir,
                                 files   => $hashref->{numfiles},
                                 subdirs => $hashref->{numdirs},
                                 bytes   => $hashref->{bytes},
                                 size    => $size,
                                 action  => $action,
                               );
               if ($action eq 'delete') {
                   $delflag = 1;
               }
               &write_log('author',$namespace,\%storehash,$delflag,$auname,
                          $audom,$auname,$audom);
           }
       }
       return;
   }
   
 sub get_course_adv_roles {  sub get_course_adv_roles {
     my ($cid,$codes) = @_;      my ($cid,$codes) = @_;
     $cid=$env{'request.course.id'} unless (defined($cid));      $cid=$env{'request.course.id'} unless (defined($cid));
Line 6044  sub courselastaccess { Line 6171  sub courselastaccess {
 sub extract_lastaccess {  sub extract_lastaccess {
     my ($returnhash,$rep) = @_;      my ($returnhash,$rep) = @_;
     if (ref($returnhash) eq 'HASH') {      if (ref($returnhash) eq 'HASH') {
         unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' ||           unless ($rep eq 'unknown_cmd' || $rep eq 'no_such_host' || 
                 $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||                  $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||
                  $rep eq '') {                   $rep eq '') {
             my @pairs=split(/\&/,$rep);              my @pairs=split(/\&/,$rep);
Line 6631  sub cstore { Line 6758  sub cstore {
   
     if ($stuname) { $home=&homeserver($stuname,$domain); }      if ($stuname) { $home=&homeserver($stuname,$domain); }
   
     $symb=&symbclean($symb);      unless (($symb eq '_feedback') || ($symb eq '_discussion')) {
           $symb=&symbclean($symb);
       }
     if (!$symb) { unless ($symb=&symbread()) { return ''; } }      if (!$symb) { unless ($symb=&symbread()) { return ''; } }
   
     if (!$domain) { $domain=$env{'user.domain'}; }      if (!$domain) { $domain=$env{'user.domain'}; }
     if (!$stuname) { $stuname=$env{'user.name'}; }      if (!$stuname) { $stuname=$env{'user.name'}; }
   
     &devalidate($symb,$stuname,$domain);      unless (($symb eq '_feedback') || ($symb eq '_discussion')) {
           &devalidate($symb,$stuname,$domain);
       }
   
     $symb=escape($symb);      $symb=escape($symb);
     if (!$namespace) {       if (!$namespace) { 
Line 6647  sub cstore { Line 6778  sub cstore {
     }      }
     if (!$home) { $home=$env{'user.home'}; }      if (!$home) { $home=$env{'user.home'}; }
   
     $$storehash{'ip'}=&get_requestor_ip();      $$storehash{'ip'} = &get_requestor_ip();
     $$storehash{'host'}=$perlvar{'lonHostID'};      $$storehash{'host'}=$perlvar{'lonHostID'};
   
     my $namevalue='';      my $namevalue='';
Line 6911  sub rolesinit { Line 7042  sub rolesinit {
     my %firstaccess = &dump('firstaccesstimes', $domain, $username);      my %firstaccess = &dump('firstaccesstimes', $domain, $username);
     my %timerinterval = &dump('timerinterval', $domain, $username);      my %timerinterval = &dump('timerinterval', $domain, $username);
     my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,      my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,
         %timerintchk, %timerintenv);          %timerintchk, %timerintenv, %coauthorenv);
   
     foreach my $key (keys(%firstaccess)) {      foreach my $key (keys(%firstaccess)) {
         my ($cid, $rest) = split(/\0/, $key);          my ($cid, $rest) = split(/\0/, $key);
Line 6925  sub rolesinit { Line 7056  sub rolesinit {
   
     my %allroles=();      my %allroles=();
     my %allgroups=();      my %allgroups=();
       my %gotcoauconfig=();
       my %domdefaults=();
   
     for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {      for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {
         my $role = $rolesdump{$area};          my $role = $rolesdump{$area};
Line 6976  sub rolesinit { Line 7109  sub rolesinit {
         } else {          } else {
         # Normal role, defined in roles.tab          # Normal role, defined in roles.tab
             &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);              &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
               if (($trole eq 'ca') || ($trole eq 'aa')) {
                   (undef,my ($audom,$auname)) = split(/\//,$area);
                   unless ($gotcoauconfig{$area}) {
                       my @ca_settings = ('authoreditors','coauthorlist','coauthoroptin');
                       my %info = &userenvironment($audom,$auname,@ca_settings);
                       $gotcoauconfig{$area} = 1;
                       foreach my $item (@ca_settings) {
                           if (exists($info{$item})) {
                               my $name = $item;
                               if ($item eq 'authoreditors') {
                                   $name = 'editors';
                                   unless ($info{'authoreditors'}) {
                                       my %domdefs;
                                       if (ref($domdefaults{$audom}) eq 'HASH') {
                                           %domdefs = %{$domdefaults{$audom}};
                                       } else {
                                           %domdefs = &get_domain_defaults($audom);
                                           $domdefaults{$audom} = \%domdefs;
                                       }
                                       if ($domdefs{$name} ne '') {
                                           $info{'authoreditors'} = $domdefs{$name};
                                       } else {
                                           $info{'authoreditors'} = 'edit,xml';
                                       }
                                   }
                               }
                               $coauthorenv{"environment.internal.$name.$area"} = $info{$item};
                           }
                       }
                   }
               }
         }          }
   
         my $cid = $tdomain.'_'.$trest;          my $cid = $tdomain.'_'.$trest;
Line 7004  sub rolesinit { Line 7168  sub rolesinit {
     $env{'user.adv'} = $userroles{'user.adv'};      $env{'user.adv'} = $userroles{'user.adv'};
     $env{'user.rar'} = $userroles{'user.rar'};      $env{'user.rar'} = $userroles{'user.rar'};
   
     return (\%userroles,\%firstaccenv,\%timerintenv);      return (\%userroles,\%firstaccenv,\%timerintenv,\%coauthorenv);
 }  }
   
 sub set_arearole {  sub set_arearole {
Line 7364  sub set_adhoc_privileges { Line 7528  sub set_adhoc_privileges {
         if (&allowed('adv') eq 'F') { $tadv=1; }          if (&allowed('adv') eq 'F') { $tadv=1; }
         &appenv({'request.role.adv'    => $tadv});          &appenv({'request.role.adv'    => $tadv});
     }      }
       if ($role eq 'ca') {
           my @ca_settings = ('authoreditors','coauthorlist');
           my %info = &userenvironment($dcdom,$pickedcourse,@ca_settings);
           foreach my $item (@ca_settings) {
               if (exists($info{$item})) {
                   my $name = $item;
                   if ($item eq 'authoreditors') {
                       $name = 'editors';
                       unless ($info{'authoreditors'}) {
                           my %domdefs = &get_domain_defaults($dcdom);
                           if ($domdefs{$name} ne '') {
                               $info{'authoreditors'} = $domdefs{$name};
                           } else {
                               $info{'authoreditors'} = 'edit,xml';
                           }
                       }
                   }
                   &appenv({"environment.internal.$name./$dcdom/$pickedcourse" => $info{$item}});
               }
           }
       }
 }  }
   
 # --------------------------------------------------------------- get interface  # --------------------------------------------------------------- get interface
Line 7898  sub portfolio_access { Line 8083  sub portfolio_access {
 }  }
   
 sub get_portfolio_access {  sub get_portfolio_access {
     my ($udom,$unum,$file_name,$group,$clientip,$access_hash) = @_;      my ($udom,$unum,$file_name,$group,$clientip,$access_hash,$portaccessref) = @_;
   
     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 7907  sub get_portfolio_access { Line 8092  sub get_portfolio_access {
  $access_hash = $access_controls{$file_name};   $access_hash = $access_controls{$file_name};
     }      }
   
     my ($public,$guest,@domains,@users,@courses,@groups,@ips);      my $portaccess;
       if (ref($portaccess) eq 'SCALAR') {
           $portaccess = $$portaccessref;
       } else {
           $portaccess = &usertools_access($unum,$udom,'portaccess',undef,'tools');
       }
   
       my ($public,$guest,@domains,@users,@courses,@groups,@ips,@userips);
     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})) {
             my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);              my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
               next if (($scope ne 'ip') && ($portaccess == 0));
             if ($start > $now) {              if ($start > $now) {
                 next;                  next;
             }              }
Line 7933  sub get_portfolio_access { Line 8126  sub get_portfolio_access {
                 push(@groups,$key);                  push(@groups,$key);
             } elsif ($scope eq 'ip') {              } elsif ($scope eq 'ip') {
                 push(@ips,$key);                  push(@ips,$key);
               } elsif ($scope eq 'userip') {
                   push(@userips,$key);
             }              }
         }          }
         if ($public) {          if ($public) {
Line 7950  sub get_portfolio_access { Line 8145  sub get_portfolio_access {
             if ($allowed) {              if ($allowed) {
                 return 'ok';                  return 'ok';
             }              }
           } elsif (@userips > 0) {
               my $allowed;
               foreach my $useripkey (@userips) {
                   if (ref($access_hash->{$useripkey}{'ip'}) eq 'ARRAY') {
                       if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$useripkey}{'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 8155  sub usertools_access { Line 8363  sub usertools_access {
         %tools = (          %tools = (
                       requestauthor => 1,                        requestauthor => 1,
                  );                   );
       } elsif ($context eq 'authordefaults') {
           %tools = (
                         webdav    => 1,
                    );
     } else {      } else {
         %tools = (          %tools = (
                       aboutme   => 1,                        aboutme   => 1,
                       blog      => 1,                        blog      => 1,
                       webdav    => 1,                        webdav    => 1,
                       portfolio => 1,                        portfolio => 1,
                         portaccess => 1,
                       timezone  => 1,                        timezone  => 1,
                  );                   );
     }      }
Line 8177  sub usertools_access { Line 8390  sub usertools_access {
                 return $env{'environment.canrequest.'.$tool};                  return $env{'environment.canrequest.'.$tool};
             } elsif ($context eq 'requestauthor') {              } elsif ($context eq 'requestauthor') {
                 return $env{'environment.canrequest.author'};                  return $env{'environment.canrequest.author'};
               } elsif ($context eq 'authordefaults') {
                   if ($tool eq 'webdav') {
                       return $env{'environment.availabletools.'.$tool};
                   }
             } else {              } else {
                 return $env{'environment.availabletools.'.$tool};                  return $env{'environment.availabletools.'.$tool};
             }              }
Line 8185  sub usertools_access { Line 8402  sub usertools_access {
   
     my ($toolstatus,$inststatus,$envkey);      my ($toolstatus,$inststatus,$envkey);
     if ($context eq 'requestauthor') {      if ($context eq 'requestauthor') {
         $envkey = $context;           $envkey = $context;
       } elsif ($context eq 'authordefaults') {
           if ($tool eq 'webdav') {
               $envkey = 'tools.'.$tool;
           }
     } else {      } else {
         $envkey = $context.'.'.$tool;          $envkey = $context.'.'.$tool;
     }      }
Line 8759  sub allowed { Line 8980  sub allowed {
   
 # If this is generating or modifying users, exit with special codes  # If this is generating or modifying users, exit with special codes
   
     if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) {      if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:vca:vaa:'=~/\:\Q$priv\E\:/) {
  if (($priv eq 'cca') || ($priv eq 'caa')) {   if (($priv eq 'cca') || ($priv eq 'caa')) {
     my ($audom,$auname)=split('/',$uri);      my ($audom,$auname)=split('/',$uri);
 # no author name given, so this just checks on the general right to make a co-author in this domain  # no author name given, so this just checks on the general right to make a co-author in this domain
Line 8768  sub allowed { Line 8989  sub allowed {
     if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) ||      if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) ||
  (($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) &&   (($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) &&
  ($audom ne $env{'request.role.domain'}))) { return ''; }   ($audom ne $env{'request.role.domain'}))) { return ''; }
    } elsif (($priv eq 'vca') || ($priv eq 'vaa')) {
               my ($audom,$auname)=split('/',$uri);
               unless ($auname) { return $thisallowed; }
               unless (($env{'request.role'} eq "dc./$audom") ||
                       ($env{'request.role'} eq "ca./$uri")) {
                   return '';
               }
  }   }
  return $thisallowed;   return $thisallowed;
     }      }
Line 9111  sub constructaccess { Line 9339  sub constructaccess {
             if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) &&              if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) &&
                 ($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) {                  ($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) {
                 if (&allowed('mdc',$env{'request.course.id'})) {                  if (&allowed('mdc',$env{'request.course.id'})) {
                       return if ($env{'course.'.$env{'request.course.id'}.'.internal.crsauthor'} eq '0');
                       unless ($env{'course.'.$env{'request.course.id'}.'.internal.crsauthor'}) {
                           my %domdefs = &get_domain_defaults($ownerdomain);
                           my $type = lc($env{'course.'.$env{'request.course.id'}.'.type'});
                           unless (($type eq 'community') || ($type eq 'placement')) {
                               $type = 'unofficial';
                               if ($env{'course.'.$env{'request.course.id'}.'internal.coursecode'} ne '') {
                                   $type = 'official';
                               } elsif ($env{'course.'.$env{'request.course.id'}.'internal.textbook'} ne '') {
                                   $type = 'textbook';
                               } else {
                                   $type = 'unofficial';
                               }
                           }
                           return if ($domdefs{$type.'crsauthor'} eq '0');
                       }
                     $ownerhome = $env{'course.'.$env{'request.course.id'}.'.home'};                      $ownerhome = $env{'course.'.$env{'request.course.id'}.'.home'};
                     return ($ownername,$ownerdomain,$ownerhome);                      return ($ownername,$ownerdomain,$ownerhome);
                 }                  }
Line 10190  sub auto_instsec_reformat { Line 10434  sub auto_instsec_reformat {
             my $info = &freeze_escape($instsecref);              my $info = &freeze_escape($instsecref);
             my $response=&reply('autoinstsecreformat:'.$cdom.':'.              my $response=&reply('autoinstsecreformat:'.$cdom.':'.
                                 $action.':'.$info,$server);                                  $action.':'.$info,$server);
             next if ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/);              next if ($response =~ /(con_lost|error|no_such_host|refused|unknown_cmd)/);
             my @items = split(/&/,$response);              my @items = split(/&/,$response);
             foreach my $item (@items) {              foreach my $item (@items) {
                 my ($key,$value) = split(/=/,$item);                  my ($key,$value) = split(/=/,$item);
Line 10272  sub auto_export_grades { Line 10516  sub auto_export_grades {
             my $grades = &freeze_escape($gradesref);              my $grades = &freeze_escape($gradesref);
             my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'.              my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'.
                                 $info.':'.$grades,$homeserver);                                  $info.':'.$grades,$homeserver);
             unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/) {              unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_cmd)/) {
                 my @items = split(/&/,$response);                  my @items = split(/&/,$response);
                 foreach my $item (@items) {                  foreach my $item (@items) {
                     my ($key,$value) = split('=',$item);                      my ($key,$value) = split('=',$item);
Line 10537  sub plaintext { Line 10781  sub plaintext {
 sub assignrole {  sub assignrole {
     my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,      my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,
         $context,$othdomby,$requester,$reqsec,$reqrole)=@_;          $context,$othdomby,$requester,$reqsec,$reqrole)=@_;
     my $mrole;      my ($mrole,$rolelogcontext);
     if ($role =~ /^cr\//) {      if ($role =~ /^cr\//) {
         my $cwosec=$url;          my $cwosec=$url;
         $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;          $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
Line 10734  sub assignrole { Line 10978  sub assignrole {
                             }                              }
                         }                          }
                     }                      }
                   } elsif (($context eq 'author') && (($role eq 'ca' || $role eq 'aa'))) {
                       if ($url =~ m{^/($match_domain)/($match_username)$}) {
                           my ($audom,$auname) = ($1,$2);
                           if ((&Apache::lonnet::allowed('v'.$role,"$audom/$auname")) &&
                               ($env{"environment.internal.manager.$url"})) {
                               $refused = '';
                               $rolelogcontext = 'coauthor';
                           }
                       }
                 }                  }
                 if ($refused) {                  if ($refused) {
                     &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.                      &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
Line 10801  sub assignrole { Line 11054  sub assignrole {
             &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,              &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                            $context,$othdomby,$requester);                             $context,$othdomby,$requester);
         } elsif (($role eq 'ca') || ($role eq 'aa')) {          } elsif (($role eq 'ca') || ($role eq 'aa')) {
               if ($rolelogcontext eq '') {
                   $rolelogcontext = $context;
               }
             &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,              &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                              $context,$othdomby,$requester);                                $rolelogcontext,$othdomby,$requester); 
         }          }
         if ($role eq 'cc') {          if ($role eq 'cc') {
             &autoupdate_coowners($url,$end,$start,$uname,$udom);              &autoupdate_coowners($url,$end,$start,$uname,$udom);
Line 11453  sub is_course { Line 11709  sub is_course {
 }  }
   
 sub store_userdata {  sub store_userdata {
     my ($storehash,$datakey,$namespace,$udom,$uname) = @_;      my ($storehash,$datakey,$namespace,$udom,$uname,$ip) = @_;
     my $result;      my $result;
     if ($datakey ne '') {      if ($datakey ne '') {
         if (ref($storehash) eq 'HASH') {          if (ref($storehash) eq 'HASH') {
Line 11465  sub store_userdata { Line 11721  sub store_userdata {
             if (($uhome eq '') || ($uhome eq 'no_host')) {              if (($uhome eq '') || ($uhome eq 'no_host')) {
                 $result = 'error: no_host';                  $result = 'error: no_host';
             } else {              } else {
                 $storehash->{'ip'} = &get_requestor_ip();                  if ($ip ne '') {
                       $storehash->{'ip'} = $ip;
                   } else {
                       $storehash->{'ip'} = &get_requestor_ip();
                   }
                 $storehash->{'host'} = $perlvar{'lonHostID'};                  $storehash->{'host'} = $perlvar{'lonHostID'};
   
                 my $namevalue='';                  my $namevalue='';
Line 12320  sub stat_file { Line 12580  sub stat_file {
 # $relpath - Current path (relative to top level).  # $relpath - Current path (relative to top level).
 # $dirhashref - reference to hash to populate with URLs of directories (Required)  # $dirhashref - reference to hash to populate with URLs of directories (Required)
 # $filehashref - reference to hash to populate with URLs of files (Optional)  # $filehashref - reference to hash to populate with URLs of files (Optional)
   # $getlastmod - if true, will set value for each key in innerhash in $filehashref
   #               to last modification time of file; value set to 1 otherwise.
 #  #
 # Returns: nothing  # Returns: nothing
 #  #
Line 12332  sub stat_file { Line 12594  sub stat_file {
 #  #
   
 sub recursedirs {  sub recursedirs {
     my ($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$relpath,$dirhashref,$filehashref) = @_;      my ($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,
           $relpath,$dirhashref,$filehashref,$getlastmod) = @_;
     return unless (ref($dirhashref) eq 'HASH');      return unless (ref($dirhashref) eq 'HASH');
     my $docroot = $perlvar{'lonDocRoot'};      my $docroot = $perlvar{'lonDocRoot'};
     my $currpath = $docroot.$toppath;      my $currpath = $docroot.$toppath;
Line 12340  sub recursedirs { Line 12603  sub recursedirs {
         $currpath .= "/$relpath";          $currpath .= "/$relpath";
     }      }
     my ($savefile,$checkinc,$checkexc);      my ($savefile,$checkinc,$checkexc);
     if (ref($filehashref)) {      if (ref($filehashref) eq 'HASH') {
         $savefile = 1;          $savefile = 1;
     }      }
     if (ref($include) eq 'HASH') {      if (ref($include) eq 'HASH') {
Line 12363  sub recursedirs { Line 12626  sub recursedirs {
                     }                      }
                     $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;                      $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
                     if ($recurse) {                      if ($recurse) {
                         &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref);                          &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,
                                        $toppath,$newpath,$dirhashref,$filehashref,$getlastmod);
                     }                      }
                 } elsif (($savefile) || ($relpath eq '')) {                  } elsif (($savefile) || ($relpath eq '')) {
                     next if ($nonemptydir && $filecount);                      next if ($nonemptydir && $filecount);
Line 12380  sub recursedirs { Line 12644  sub recursedirs {
                         $dirhashref->{'/'} = 1;                          $dirhashref->{'/'} = 1;
                     }                      }
                     if ($savefile) {                      if ($savefile) {
                           my $value;
                           if ($getlastmod) {
                               ($value) = (stat("$currpath/$item"))[9];
                           } else {
                               $value = 1;
                           }
                         if ($relpath eq '') {                          if ($relpath eq '') {
                             $filehashref->{'/'}{$item} = 1;                              $filehashref->{'/'}{$item} = $value
                         } else {                          } else {
                             $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;                              $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = $value;
                         }                          }
                     }                      }
                     $filecount ++;                      $filecount ++;
Line 12392  sub recursedirs { Line 12662  sub recursedirs {
             closedir($dirh);              closedir($dirh);
         }          }
     } else {      } else {
         my ($dirlistref,$listerror) =          my $url = $toppath;
             &dirlist($toppath.$relpath);          if ($relpath ne '') {
               $url = $toppath.'/'.$relpath;
           }
           my ($dirlistref,$listerror) = &dirlist($url);
         my @dir_lines;          my @dir_lines;
         my $dirptr=16384;          my $dirptr=16384;
         if (ref($dirlistref) eq 'ARRAY') {          if (ref($dirlistref) eq 'ARRAY') {
Line 12417  sub recursedirs { Line 12690  sub recursedirs {
                     }                      }
                     $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;                      $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
                     if ($recurse) {                      if ($recurse) {
                         &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref);                          &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,
                                        $toppath,$newpath,$dirhashref,$filehashref,$getlastmod);
                     }                      }
                 } elsif (($savefile) || ($relpath eq '')) {                  } elsif (($savefile) || ($relpath eq '')) {
                     next if ($nonemptydir && $filecount);                      next if ($nonemptydir && $filecount);
                     if ($checkinc || $checkexc) {                      if ($checkinc || $checkexc) {
                         my $extension;                          my ($extension) = ($item =~ /\.(\w+)$/);
                         if ($checkinc) {                          if ($checkinc) {
                             next unless ($extension && $include->{$extension});                              next unless ($extension && $include->{$extension});
                         }                          }
Line 12434  sub recursedirs { Line 12708  sub recursedirs {
                         $dirhashref->{'/'} = 1;                          $dirhashref->{'/'} = 1;
                     }                      }
                     if ($savefile) {                      if ($savefile) {
                           my $value;
                           if ($getlastmod) {
                               $value = $mtime;
                           } else {
                               $value = 1;
                           }
                         if ($relpath eq '') {                          if ($relpath eq '') {
                             $filehashref->{'/'}{$item} = 1;                              $filehashref->{'/'}{$item} = $value;
                         } else {                          } else {
                             $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;                              $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = $value;
                         }                          }
                     }                      }
                     $filecount ++;                       $filecount ++; 
Line 12464  sub priv_exclude { Line 12744  sub priv_exclude {
            };             };
 }  }
   
   sub res_exclude {
       return {
                meta => 1,
                subscription => 1,
                rights => 1,
              };
   }
   
 # -------------------------------------------------------- Value of a Condition  # -------------------------------------------------------- Value of a Condition
   
 # gets the value of a specific preevaluated condition  # gets the value of a specific preevaluated condition
Line 12787  sub domainlti_itemid { Line 13075  sub domainlti_itemid {
     return $itemid;      return $itemid;
 }  }
   
   sub get_ltitools_id {
       my ($context,$cdom,$cnum,$title) = @_;
       my ($lockhash,$tries,$gotlock,$id,$error);
   
       # get lock on ltitools db
       $lockhash = {
                      lock => $env{'user.name'}.
                              ':'.$env{'user.domain'},
                   };
       $tries = 0;
       if ($context eq 'domain') {
           $gotlock = &newput_dom('ltitools',$lockhash,$cdom);
       } else {
           $gotlock = &newput('ltitools',$lockhash,$cdom,$cnum);
       }
       while (($gotlock ne 'ok') && ($tries<10)) {
           $tries ++;
           sleep (0.1);
           if ($context eq 'domain') {
               $gotlock = &newput_dom('ltitools',$lockhash,$cdom);
           } else {
               $gotlock = &newput('ltitools',$lockhash,$cdom,$cnum);
           }
       }
       if ($gotlock eq 'ok') {
           my %currids;
           if ($context eq 'domain') {
               %currids = &dump_dom('ltitools',$cdom);
           } else {
               %currids = &dump('ltitools',$cdom,$cnum);
           }
           if ($currids{'lock'}) {
               delete($currids{'lock'});
               if (keys(%currids)) {
                   my @curr = sort { $a <=> $b } keys(%currids);
                   if ($curr[-1] =~ /^\d+$/) {
                       $id = 1 + $curr[-1];
                   }
               } else {
                   $id = 1;
               }
               if ($id) {
                   if ($context eq 'domain') {
                       unless (&newput_dom('ltitools',{ $id => $title },$cdom) eq 'ok') {
                           $error = 'nostore';
                       }
                   } else {
                       unless (&newput('ltitools',{ $id => $title },$cdom,$cnum) eq 'ok') {
                           $error = 'nostore';
                       }
                   }
               } else {
                   $error = 'nonumber';
               }
           }
           my $dellockoutcome;
           if ($context eq 'domain') {
               $dellockoutcome = &del_dom('ltitools',['lock'],$cdom);
           } else {
               $dellockoutcome = &del('ltitools',['lock'],$cdom,$cnum);
           }
       } else {
           $error = 'nolock';
       }
       return ($id,$error);
   }
   
 sub count_supptools {  sub count_supptools {
     my ($cnum,$cdom,$ignorecache,$reload)=@_;      my ($cnum,$cdom,$ignorecache,$reload)=@_;
     my $hashid=$cnum.':'.$cdom;      my $hashid=$cnum.':'.$cdom;
Line 14762  sub whichuser { Line 15117  sub whichuser {
     $courseid=$tmp_courseid;      $courseid=$tmp_courseid;
     ($domain)=&get_env_multiple('form.grade_domain');      ($domain)=&get_env_multiple('form.grade_domain');
     ($name)=&get_env_multiple('form.grade_username');      ($name)=&get_env_multiple('form.grade_username');
               if ($name eq 'public' && $domain eq 'public') {
                   $publicuser = 1;
               }
     return ($symb,$courseid,$domain,$name,$publicuser);      return ($symb,$courseid,$domain,$name,$publicuser);
  }   }
     }      }
Line 14778  sub whichuser { Line 15136  sub whichuser {
     $env{'form.username'}.=time.rand(10000000);      $env{'form.username'}.=time.rand(10000000);
  }   }
  $name.=$env{'form.username'};   $name.=$env{'form.username'};
           $publicuser = 1;
     }      }
     return ($symb,$courseid,$domain,$name,$publicuser);      return ($symb,$courseid,$domain,$name,$publicuser);
   
Line 14866  sub repcopy_userfile { Line 15225  sub repcopy_userfile {
     return 'ok';      return 'ok';
 }  }
   
   sub repcopy_crsprivfile {
       my ($src,$dest) = @_;
       my $result;
       if ($src =~ m{^/priv/($match_domain)/($match_courseid)/(.+)$}) {
           my ($cdom,$cnum,$filepath) = ($1,$2,$3);
           $filepath =~ s/\.{2,}//g;
           my $chome = &homeserver($cnum,$cdom);
           unless ($chome eq 'no_host') {
               my @ids=&current_machine_ids();
               unless (grep(/^\Q$chome\E$/,@ids)) {
                   if (&is_course($cdom,$cnum)) {
                       my $londocroot = $perlvar{'lonDocRoot'};
                       if ($dest =~ m{^\Q$londocroot/priv/\E$match_domain/$match_username/.*\Q$filepath\E$}) {
                           my $cmd = 'crsfilefrompriv:'.&escape($filepath).':'.&escape($cnum).':'.&escape($cdom);
                           $result = &reply($cmd,$chome);
                           unless (($result eq 'unknown_cmd') || ($result =~ /^error:/)) {
                               my $url = &unescape($result);
                               if ($url =~ m{^https?://[^/]+\Q/userfiles/$cdom/$cnum/priv/$filepath\E$}) {
                                   my $request=new HTTP::Request('GET',$url);
                                   my $response=&LONCAPA::LWPReq::makerequest($chome,$request,'',\%perlvar,1200,1);
                                   if ($response->is_error()) {
                                       $result = 'error: '.$response->status_line;
                                   } else {
                                       if (open(my $fh,'>',$dest)) {
                                           print $fh $response->content;
                                           close($fh);
                                           $result = 'ok';
                                       } else {
                                           $result = 'error: nowrite';
                                       }
                                   }
                               } else {
                                   $result = 'error: invalidurl';
                               }
                           }
                       }
                   }
               }
           }
       }
       return $result;
   }
   
 sub tokenwrapper {  sub tokenwrapper {
     my $uri=shift;      my $uri=shift;
     $uri=~s|^https?\://([^/]+)||;      $uri=~s|^https?\://([^/]+)||;
Removed from v.1.1512  
changed lines
  Added in v.1.1537

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