[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.1509 and 1.1531

version 1.1509, 2023/05/22 15:09:15 version 1.1531, 2024/12/25 06:07:01
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 415  sub remote_devalidate_cache { Line 419  sub remote_devalidate_cache {
     return $response;      return $response;
 }  }
   
   sub sign_lti {
       my ($cdom,$cnum,$crsdef,$type,$context,$url,$ltinum,$keynum,$paramsref,$inforef) = @_;
       my $chome;
       if (&domain($cdom) ne '') {
           if ($crsdef) {
               $chome = &homeserver($cnum,$cdom);
           } else {
               $chome = &domain($cdom,'primary');
           }
       }
       if ($cdom && $chome && ($chome ne 'no_host')) {
           if ((ref($paramsref) eq 'HASH') &&
               (ref($inforef) eq 'HASH')) {
               my $rep;
               if (grep { $_ eq $chome } &current_machine_ids()) {
                   # domain information is hosted on this machine
                   $rep =
                       &LONCAPA::Lond::sign_lti_payload($cdom,$cnum,$crsdef,$type,
                                                        $context,$url,$ltinum,$keynum,
                                                        $perlvar{'lonVersion'},
                                                        $paramsref,$inforef);
                   if (ref($rep) eq 'HASH') {
                       return ('ok',$rep);
                   }
               } else {
                   my ($escurl,$params,$info);
                   $escurl = &escape($url);
                   if (ref($paramsref) eq 'HASH') {
                       $params = &freeze_escape($paramsref);
                   }
                   if (ref($inforef) eq 'HASH') {
                       $info = &freeze_escape($inforef);
                   }
                   $rep=&reply("encrypt:signlti:$cdom:$cnum:$crsdef:$type:$context:$escurl:$ltinum:$keynum:$params:$info",$chome);
               }
               if (($rep eq '') || ($rep =~ /^con_lost|error|no_such_host|unknown_cmd/i)) {
                   return ();
               } elsif (($inforef->{'respfmt'} eq 'to_post_body') ||
                        ($inforef->{'respfmt'} eq 'to_authorization_header')) {
                   return ('ok',$rep);
               } else {
                   my %returnhash;
                   foreach my $item (split(/\&/,$rep)) {
                       my ($name,$value)=split(/\=/,$item);
                       $returnhash{&unescape($name)}=&thaw_unescape($value);
                   }
                   return('ok',\%returnhash);
               }
           } else {
               return ();
           }
       } else {
           return ();
           &logthis("sign_lti failed - no homeserver and/or domain ($cdom) ($chome)");
       }
   }
   
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
 sub subreply {  sub subreply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
Line 2696  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',],$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 2726  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 2744  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 2757  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 2766  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 2782  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 2899  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 2911  sub get_domain_defaults { Line 3005  sub get_domain_defaults {
             }              }
         }          }
     }      }
       if (ref($domconfig{'privacy'}) eq 'HASH') {
           if (ref($domconfig{'privacy'}{'approval'}) eq 'HASH') {
               foreach my $domtype ('instdom','extdom') {
                   if (ref($domconfig{'privacy'}{'approval'}{$domtype}) eq 'HASH') {
                       foreach my $roletype ('domain','author','course','community') {
                           if ($domconfig{'privacy'}{'approval'}{$domtype}{$roletype} eq 'user') {
                               $domdefaults{'userapprovals'} = 1;
                               last;
                           }
                       }
                   }
                   last if ($domdefaults{'userapprovals'});
               }
           }
       }
     &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);      &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
     return %domdefaults;      return %domdefaults;
 }  }
Line 3846  sub can_edit_resource { Line 3955  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 5367  sub userrolelog { Line 5499  sub userrolelog {
 }  }
   
 sub courserolelog {  sub courserolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;      my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,
           $context,$othdomby,$requester)=@_;
     if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {      if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
         my $cdom = $1;          my $cdom = $1;
         my $cnum = $2;          my $cnum = $2;
Line 5380  sub courserolelog { Line 5513  sub courserolelog {
                            selfenroll => $selfenroll,                             selfenroll => $selfenroll,
                            context    => $context,                             context    => $context,
                         );                          );
           if ($othdomby) {
               if ($othdomby eq 'othdombydc') {
                   $storehash{'approval'} = 'domain';
               } elsif ($othdomby eq 'othdombyuser') {
                   $storehash{'approval'} = 'user'; 
               }
               if ($requester ne '') {
                   $storehash{'requester'} = $requester;
               }
           }
         if ($trole eq 'gr') {          if ($trole eq 'gr') {
             $namespace = 'groupslog';              $namespace = 'groupslog';
             $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 5396  sub courserolelog { Line 5569  sub courserolelog {
 }  }
   
 sub domainrolelog {  sub domainrolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;      my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,
           $context,$othdomby,$requester)=@_;
     if ($area =~ m{^/($match_domain)/$}) {      if ($area =~ m{^/($match_domain)/$}) {
         my $cdom = $1;          my $cdom = $1;
         my $domconfiguser = &get_domainconfiguser($cdom);          my $domconfiguser = &get_domainconfiguser($cdom);
Line 5407  sub domainrolelog { Line 5581  sub domainrolelog {
                            end     => $tend,                             end     => $tend,
                            context => $context,                             context => $context,
                         );                          );
           if ($othdomby) {
               if ($othdomby eq 'othdombydc') {
                   $storehash{'approval'} = 'domain';
               } elsif ($othdomby eq 'othdombyuser') {
                   $storehash{'approval'} = 'user';
               }
               if ($requester ne '') {
                   $storehash{'requester'} = $requester;
               }
           }
         &write_log('domain',$namespace,\%storehash,$delflag,$username,          &write_log('domain',$namespace,\%storehash,$delflag,$username,
                    $domain,$domconfiguser,$cdom);                     $domain,$domconfiguser,$cdom);
     }      }
Line 5415  sub domainrolelog { Line 5599  sub domainrolelog {
 }  }
   
 sub coauthorrolelog {  sub coauthorrolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;      my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,
           $context,$othdomby,$requester)=@_;
     if ($area =~ m{^/($match_domain)/($match_username)$}) {      if ($area =~ m{^/($match_domain)/($match_username)$}) {
         my $audom = $1;          my $audom = $1;
         my $auname = $2;          my $auname = $2;
Line 5426  sub coauthorrolelog { Line 5611  sub coauthorrolelog {
                            end     => $tend,                             end     => $tend,
                            context => $context,                             context => $context,
                         );                          );
           if ($othdomby) {
               if ($othdomby eq 'othdombydc') {
                   $storehash{'approval'} = 'domain';
               } elsif ($othdomby eq 'othdombyuser') {
                   $storehash{'approval'} = 'user';
               }
               if ($requester ne '') {
                   $storehash{'requester'} = $requester;
               }
           }
         &write_log('author',$namespace,\%storehash,$delflag,$username,          &write_log('author',$namespace,\%storehash,$delflag,$username,
                    $domain,$auname,$audom);                     $domain,$auname,$audom);
     }      }
     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 5939  sub courselastaccess { Line 6167  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 6521  sub store { Line 6749  sub store {
 # -------------------------------------------------------------- Critical Store  # -------------------------------------------------------------- Critical Store
   
 sub cstore {  sub cstore {
     my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_;      my ($storehash,$symb,$namespace,$domain,$stuname,$laststore,$ip,$nolog) = @_;
     my $home='';      my $home='';
   
     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 6542  sub cstore { Line 6774  sub cstore {
     }      }
     if (!$home) { $home=$env{'user.home'}; }      if (!$home) { $home=$env{'user.home'}; }
   
     $$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 6550  sub cstore { Line 6786  sub cstore {
         $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';          $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
     }      }
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);      unless ($nolog) {
           &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
       }
     return critical      return critical
                 ("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home");                  ("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home");
 }  }
Line 6806  sub rolesinit { Line 7044  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 6820  sub rolesinit { Line 7058  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 6871  sub rolesinit { Line 7111  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 6899  sub rolesinit { Line 7170  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 7793  sub portfolio_access { Line 8064  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 7802  sub get_portfolio_access { Line 8073  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 7828  sub get_portfolio_access { Line 8107  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 7845  sub get_portfolio_access { Line 8126  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 8050  sub usertools_access { Line 8344  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 8072  sub usertools_access { Line 8371  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 8080  sub usertools_access { Line 8383  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 8192  sub is_course_owner { Line 8499  sub is_course_owner {
 }  }
   
 sub is_advanced_user {  sub is_advanced_user {
     my ($udom,$uname) = @_;      my ($udom,$uname,$nocache) = @_;
       my ($is_adv,$is_author,$use_cache,$hashid);
     if ($udom ne '' && $uname ne '') {      if ($udom ne '' && $uname ne '') {
         if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {          if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
             if (wantarray) {              if (wantarray) {
Line 8200  sub is_advanced_user { Line 8508  sub is_advanced_user {
             } else {              } else {
                 return $env{'user.adv'};                  return $env{'user.adv'};
             }              }
           } elsif (!$nocache) {
               $use_cache = 1;
               $hashid = "$udom:$uname";  
               my ($info,$cached)=&is_cached_new('isadvau',$hashid);
               if ($cached) {
                   ($is_adv,$is_author) = split(/:/,$info);
                   if (wantarray) {
                       return ($is_adv,$is_author);
                   }
                   return $is_adv; 
               }
         }          }
     }      }
     my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);      my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
     my %allroles;      my %allroles;
     my ($is_adv,$is_author);  
     foreach my $role (keys(%roleshash)) {      foreach my $role (keys(%roleshash)) {
         my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);          my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);
         my $area = '/'.$tdomain.'/'.$trest;          my $area = '/'.$tdomain.'/'.$trest;
Line 8235  sub is_advanced_user { Line 8553  sub is_advanced_user {
             }              }
         }          }
     }      }
       if ($use_cache) {
           my $cachetime = 600;
           &do_cache_new('isadvau',$hashid,$is_adv.':'.$is_author,$cachetime);
       }
     if (wantarray) {      if (wantarray) {
         return ($is_adv,$is_author);          return ($is_adv,$is_author);
     }      }
Line 8639  sub allowed { Line 8961  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 8648  sub allowed { Line 8970  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 8991  sub constructaccess { Line 9320  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 10070  sub auto_instsec_reformat { Line 10415  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 10152  sub auto_export_grades { Line 10497  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 10282  sub toggle_coursegroup_status { Line 10627  sub toggle_coursegroup_status {
 }  }
   
 sub modify_group_roles {  sub modify_group_roles {
     my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context) = @_;      my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context,
           $othdomby,$requester) = @_;
     my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;      my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
     my $role = 'gr/'.&escape($userprivs);      my $role = 'gr/'.&escape($userprivs);
     my ($uname,$udom) = split(/:/,$user);      my ($uname,$udom) = split(/:/,$user);
     my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context);      my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context,
                                $othdomby,$requester);
     if ($result eq 'ok') {      if ($result eq 'ok') {
         &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);          &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
     }      }
Line 10414  sub plaintext { Line 10761  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)=@_;          $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/;
         if ((!&allowed('ccr',$cwosec)) && (!&allowed('ccr',$udom))) {          if ((!&allowed('ccr',$cwosec)) && (!&allowed('ccr',$udom))) {
            my $refused = 1;              my $refused = 1;
            if ($context eq 'requestcourses') {              if ($context eq 'requestcourses') {
                if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {                  if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
                    if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {                      if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {
                        if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {                          if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {
                            my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});                              my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
                            my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));                              my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
                            if ($crsenv{'internal.courseowner'} eq                              if ($crsenv{'internal.courseowner'} eq
                                $env{'user.name'}.':'.$env{'user.domain'}) {                                  $env{'user.name'}.':'.$env{'user.domain'}) {
                                $refused = '';                                  $refused = '';
                            }                              }
                        }                          }
                    }                      }
                }                  }
            }              } elsif (($context eq 'course') && ($othdomby eq 'othdombyuser')) {
            if ($refused) {                  my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
                &logthis('Refused custom assignrole: '.                  my ($sec) = ($url =~ m{^/\Q$cwosec\E/(.*)$});
                         $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.                  my $key = "$uname:$udom:$role:$sec";
                         ' by '.$env{'user.name'}.' at '.$env{'user.domain'});                  my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$cdom,$cnum);
                return 'refused';                  if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
            }                      if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
                           $refused = '';
                       }
                   }
               }
               if ($refused) {
                   &logthis('Refused custom assignrole: '.
                            $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.
                            ' by '.$env{'user.name'}.' at '.$env{'user.domain'});
                   return 'refused';
               }
         }          }
         $mrole='cr';          $mrole='cr';
     } elsif ($role =~ /^gr\//) {      } elsif ($role =~ /^gr\//) {
         my $cwogrp=$url;          my $cwogrp=$url;
         $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};          $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
         unless (&allowed('mdg',$cwogrp)) {          if (!&allowed('mdg',$cwogrp)) {
             &logthis('Refused group assignrole: '.              my $refused = 1;
               $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.              if (($refused) && ($othdomby eq 'othdombyuser') && ($requester ne '') && ($reqrole ne '')) {
                     $env{'user.name'}.' at '.$env{'user.domain'});                  my ($cdom,$cnum) = ($cwogrp =~ m{^/?($match_domain)/($match_courseid)$});
             return 'refused';                  my $key = "$uname:$udom:$reqrole:$reqsec";
                   my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$cdom,$cnum);
                   if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
                       if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
                           $refused = '';
                       }
                   }
               }
               if ($refused) {
                   &logthis('Refused group assignrole: '.
                            $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
                            $env{'user.name'}.' at '.$env{'user.domain'});
                   return 'refused';
               }
         }          }
         $mrole='gr';          $mrole='gr';
     } else {      } else {
Line 10467  sub assignrole { Line 10837  sub assignrole {
             }              }
             if ($refused) {              if ($refused) {
                 my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});                  my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
                 if (!$selfenroll && (($context eq 'course') || ($context eq 'ltienroll' && $env{'request.lti.login'}))) {                  if (!$selfenroll && ($othdomby ne 'othdombyuser') &&
                      (($context eq 'course') || ($context eq 'ltienroll' && $env{'request.lti.login'}))) {
                     my %crsenv;                      my %crsenv;
                     if ($role eq 'cc' || $role eq 'co') {                      if ($role eq 'cc' || $role eq 'co') {
                         %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));                          %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
Line 10493  sub assignrole { Line 10864  sub assignrole {
                     } elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) {                      } elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) {
                         $refused = '';                          $refused = '';
                     }                      }
                   } elsif ($othdomby eq 'othdombyuser') {
                       my ($key,%queuedrolereq);
                       if ($context eq 'course') {
                           my ($sec) = ($url =~ m{^/\Q$cwosec\E/(.*)$});
                           $key = "$uname:$udom:$role:$sec";
                           %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$cdom,$cnum);
                           if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
                               if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
                                   if ((($role eq 'cc') && ($cnum !~ /^$match_community$/)) || 
                                       (($role eq 'co') && ($cnum =~ /^$match_community$/))) {
                                       my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
                                       if ($crsenv{'internal.courseowner'} eq $requester) {
                                           $refused = '';
                                       }
                                   } elsif ($role =~ /^(?:in|ta|ep|st)$/) {
                                       $refused = '';
                                   }
                               }
                           }
                       } elsif (($context eq 'author') && ($role =~ /^ca|aa$/)) {
                           my $key = "$uname:$udom:$role"; 
                           my ($audom,$auname) = ($url =~ m{^/($match_domain)/($match_username)$});
                           if (($audom ne '') && ($auname ne '')) {
                               my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$audom,$auname);
                               if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
                                   if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
                                       $refused = '';
                                   }
                               }
                           }
                       } elsif (($context eq 'domain') && ($role ne 'dc') && ($role ne 'su')) {
                           my $key = "$uname:$udom:$role";
                           my ($roledom) = ($url =~ m{^/($match_domain)/\Q$role\E$});
                           if ($roledom ne '') {
                               my $confname = $roledom.'-domainconfig';
                               my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$roledom,$confname);
                               if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
                                   if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
                                       $refused = '';
                                   }
                               }
                           }
                       }
                 } elsif ($context eq 'requestcourses') {                  } elsif ($context eq 'requestcourses') {
                     my @possroles = ('st','ta','ep','in','cc','co');                      my @possroles = ('st','ta','ep','in','cc','co');
                     if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {                      if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
Line 10545  sub assignrole { Line 10959  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 10605  sub assignrole { Line 11028  sub assignrole {
                                                  $origstart,$selfenroll,$context);                                                   $origstart,$selfenroll,$context);
             }              }
             &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,              &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                            $selfenroll,$context);                             $selfenroll,$context,$othdomby,$requester);
         } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') ||          } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') ||
                  ($role eq 'au') || ($role eq 'dc') || ($role eq 'dh') ||                   ($role eq 'au') || ($role eq 'dc') || ($role eq 'dh') ||
                  ($role eq 'da')) {                   ($role eq 'da')) {
             &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,              &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                            $context);                             $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);                                $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 10965  sub modifystudent { Line 11391  sub modifystudent {
   
 sub modify_student_enrollment {  sub modify_student_enrollment {
     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,      my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
         $locktype,$cid,$selfenroll,$context,$credits,$instsec) = @_;          $locktype,$cid,$selfenroll,$context,$credits,$instsec,$othdomby,$requester) = @_;
     my ($cdom,$cnum,$chome);      my ($cdom,$cnum,$chome);
     if (!$cid) {      if (!$cid) {
  unless ($cid=$env{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
Line 11026  sub modify_student_enrollment { Line 11452  sub modify_student_enrollment {
  $uurl.='/'.$usec;   $uurl.='/'.$usec;
     }      }
     my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,      my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,
                              $selfenroll,$context);                               $selfenroll,$context,$othdomby,$requester);
     if ($result ne 'ok') {      if ($result ne 'ok') {
         if ($old_entry{$user} ne '') {          if ($old_entry{$user} ne '') {
             $reply = &cput('classlist',\%old_entry,$cdom,$cnum);              $reply = &cput('classlist',\%old_entry,$cdom,$cnum);
Line 11302  sub store_userdata { Line 11728  sub store_userdata {
 # ---------------------------------------------------------- Assign Custom Role  # ---------------------------------------------------------- Assign Custom Role
   
 sub assigncustomrole {  sub assigncustomrole {
     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,$selfenroll,$context)=@_;      my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,
           $selfenroll,$context,$othdomby,$requester)=@_;
     return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,      return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
                        $end,$start,$deleteflag,$selfenroll,$context);                         $end,$start,$deleteflag,$selfenroll,$context,$othdomby,
                          $requester);
 }  }
   
 # ----------------------------------------------------------------- Revoke Role  # ----------------------------------------------------------------- Revoke Role
Line 12496  sub get_domain_lti { Line 12924  sub get_domain_lti {
     } else {      } else {
         return %lti;          return %lti;
     }      }
   
     if ($context eq 'linkprot') {      if ($context eq 'linkprot') {
         $cachename = $context;          $cachename = $context;
     } else {      } else {
         $cachename = $name;          $cachename = $name;
     }      }
       
     my ($result,$cached)=&is_cached_new($cachename,$cdom);      my ($result,$cached)=&is_cached_new($cachename,$cdom);
     if (defined($cached)) {      if (defined($cached)) {
         if (ref($result) eq 'HASH') {          if (ref($result) eq 'HASH') {
Line 12518  sub get_domain_lti { Line 12944  sub get_domain_lti {
             } else {              } else {
                 %lti = %{$domconfig{$name}};                  %lti = %{$domconfig{$name}};
             }              }
             if (($context eq 'consumer') && (keys(%lti))) {  
                 my %encdomconfig = &get_dom('encconfig',[$name],$cdom,undef,1);  
                 if (ref($encdomconfig{$name}) eq 'HASH') {  
                     foreach my $id (keys(%lti)) {  
                         if (ref($encdomconfig{$name}{$id}) eq 'HASH') {  
                             foreach my $item ('key','secret') {  
                                 $lti{$id}{$item} = $encdomconfig{$name}{$id}{$item};  
                             }  
                         }  
                     }  
                 }  
             }  
         }          }
         my $cachetime = 24*60*60;          my $cachetime = 24*60*60;
         &do_cache_new($cachename,$cdom,\%lti,$cachetime);          &do_cache_new($cachename,$cdom,\%lti,$cachetime);
Line 12538  sub get_domain_lti { Line 12952  sub get_domain_lti {
 }  }
   
 sub get_course_lti {  sub get_course_lti {
     my ($cnum,$cdom) = @_;      my ($cnum,$cdom,$context) = @_;
       my ($name,$cachename,%lti);
       if ($context eq 'consumer') {
           $name = 'ltitools';
           $cachename = 'courseltitools';
       } elsif ($context eq 'provider') {
           $name = 'lti';
           $cachename = 'courselti';
       } else {
           return %lti;
       }
     my $hashid=$cdom.'_'.$cnum;      my $hashid=$cdom.'_'.$cnum;
     my %courselti;      my ($result,$cached)=&is_cached_new($cachename,$hashid);
     my ($result,$cached)=&is_cached_new('courselti',$hashid);  
     if (defined($cached)) {      if (defined($cached)) {
         if (ref($result) eq 'HASH') {          if (ref($result) eq 'HASH') {
             %courselti = %{$result};              %lti = %{$result};
         }          }
     } else {      } else {
         %courselti = &dump('lti',$cdom,$cnum,undef,undef,undef,1);          %lti = &dump($name,$cdom,$cnum,undef,undef,undef,1);
         my $cachetime = 24*60*60;          my $cachetime = 24*60*60;
         &do_cache_new('courselti',$hashid,\%courselti,$cachetime);          &do_cache_new($cachename,$hashid,\%lti,$cachetime);
     }      }
     return %courselti;      return %lti;
 }  }
   
 sub courselti_itemid {  sub courselti_itemid {
Line 12601  sub domainlti_itemid { Line 13024  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;
Removed from v.1.1509  
changed lines
  Added in v.1.1531

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