[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.1172.2.81 and 1.1172.2.99

version 1.1172.2.81, 2016/09/18 14:37:57 version 1.1172.2.99, 2018/09/11 17:21:07
Line 142  our @EXPORT = qw(%env); Line 142  our @EXPORT = qw(%env);
 sub logtouch {  sub logtouch {
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     unless (-e "$execdir/logs/lonnet.log") {      unless (-e "$execdir/logs/lonnet.log") {
  open(my $fh,">>$execdir/logs/lonnet.log");   open(my $fh,">>","$execdir/logs/lonnet.log");
  close $fh;   close $fh;
     }      }
     my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];      my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
Line 154  sub logthis { Line 154  sub logthis {
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     my $now=time;      my $now=time;
     my $local=localtime($now);      my $local=localtime($now);
     if (open(my $fh,">>$execdir/logs/lonnet.log")) {      if (open(my $fh,">>","$execdir/logs/lonnet.log")) {
  my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.   my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.
  print $fh $logstring;   print $fh $logstring;
  close($fh);   close($fh);
Line 167  sub logperm { Line 167  sub logperm {
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     my $now=time;      my $now=time;
     my $local=localtime($now);      my $local=localtime($now);
     if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) {      if (open(my $fh,">>","$execdir/logs/lonnet.perm.log")) {
  print $fh "$now:$message:$local\n";   print $fh "$now:$message:$local\n";
  close($fh);   close($fh);
     }      }
Line 436  sub reconlonc { Line 436  sub reconlonc {
   
     &logthis("Trying to reconnect lonc");      &logthis("Trying to reconnect lonc");
     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";      my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
     if (open(my $fh,"<$loncfile")) {      if (open(my $fh,"<",$loncfile)) {
  my $loncpid=<$fh>;   my $loncpid=<$fh>;
         chomp($loncpid);          chomp($loncpid);
         if (kill 0 => $loncpid) {          if (kill 0 => $loncpid) {
Line 476  sub critical { Line 476  sub critical {
             $dumpcount++;              $dumpcount++;
             {              {
  my $dfh;   my $dfh;
  if (open($dfh,">$dfilename")) {   if (open($dfh,">",$dfilename)) {
     print $dfh "$cmd\n";       print $dfh "$cmd\n"; 
     close($dfh);      close($dfh);
  }   }
Line 485  sub critical { Line 485  sub critical {
             my $wcmd='';              my $wcmd='';
             {              {
  my $dfh;   my $dfh;
  if (open($dfh,"<$dfilename")) {   if (open($dfh,"<",$dfilename)) {
     $wcmd=<$dfh>;       $wcmd=<$dfh>; 
     close($dfh);      close($dfh);
  }   }
Line 601  sub transfer_profile_to_env { Line 601  sub transfer_profile_to_env {
   
 # ---------------------------------------------------- Check for valid session   # ---------------------------------------------------- Check for valid session 
 sub check_for_valid_session {  sub check_for_valid_session {
     my ($r,$name,$userhashref) = @_;      my ($r,$name,$userhashref,$domref) = @_;
     my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));      my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
     if ($name eq '') {      if ($name eq '') {
         $name = 'lonID';          $name = 'lonID';
Line 616  sub check_for_valid_session { Line 616  sub check_for_valid_session {
     } else {      } else {
         $lonidsdir=$r->dir_config('lonIDsDir');          $lonidsdir=$r->dir_config('lonIDsDir');
     }      }
     return undef if (!-e "$lonidsdir/$handle.id");      if (!-e "$lonidsdir/$handle.id") {
           if ((ref($domref)) && ($name eq 'lonID') &&
               ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) {
               my ($possuname,$possudom,$possuhome) = ($1,$2,$3);
               if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) {
                   $$domref = $possudom;
               }
           }
           return undef;
       }
   
     my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");      my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
     return undef if (!$opened);      return undef if (!$opened);
Line 686  sub appenv { Line 695  sub appenv {
                 $env{$key}=$newenv->{$key};                  $env{$key}=$newenv->{$key};
             }              }
         }          }
         my $opened = open(my $env_file,'+<',$env{'user.environment'});          my $lonids = $perlvar{'lonIDsDir'};
         if ($opened          if ($env{'user.environment'} =~ m{^\Q$lonids/\E$match_username\_\d+\_$match_domain\_[\w\-.]+\.id$}) {
     && &timed_flock($env_file,LOCK_EX)              my $opened = open(my $env_file,'+<',$env{'user.environment'});
     &&              if ($opened
     tie(my %disk_env,'GDBM_File',$env{'user.environment'},          && &timed_flock($env_file,LOCK_EX)
         (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {          &&
     while (my ($key,$value) = each(%{$newenv})) {          tie(my %disk_env,'GDBM_File',$env{'user.environment'},
         $disk_env{$key} = $value;              (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
     }          while (my ($key,$value) = each(%{$newenv})) {
     untie(%disk_env);              $disk_env{$key} = $value;
           }
           untie(%disk_env);
               }
         }          }
     }      }
     return 'ok';      return 'ok';
Line 1002  sub choose_server { Line 1014  sub choose_server {
     if ($login_host ne '') {      if ($login_host ne '') {
         $hostname = &hostname($login_host);          $hostname = &hostname($login_host);
     }      }
     return ($login_host,$hostname,$portal_path,$isredirect);      return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load);
 }  }
   
 # --------------------------------------------- Try to change a user's password  # --------------------------------------------- Try to change a user's password
Line 1274  sub get_lonbalancer_config { Line 1286  sub get_lonbalancer_config {
 }  }
   
 sub check_loadbalancing {  sub check_loadbalancing {
     my ($uname,$udom) = @_;      my ($uname,$udom,$caller) = @_;
     my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,      my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,
         $rule_in_effect,$offloadto,$otherserver);          $rule_in_effect,$offloadto,$otherserver);
     my $lonhost = $perlvar{'lonHostID'};      my $lonhost = $perlvar{'lonHostID'};
Line 1425  sub check_loadbalancing { Line 1437  sub check_loadbalancing {
                 }                  }
             }              }
         }          }
         if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {          unless ($caller eq 'login') {
             $is_balancer = 0;              if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {
             if ($uname ne '' && $udom ne '') {                  $is_balancer = 0;
                 if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {                  if ($uname ne '' && $udom ne '') {
                       if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
   
                     &appenv({'user.loadbalexempt'     => $lonhost,                          &appenv({'user.loadbalexempt'     => $lonhost,
                              'user.loadbalcheck.time' => time});                                   'user.loadbalcheck.time' => time});
                       }
                 }                  }
             }              }
         }          }
Line 1827  sub inst_directory_query { Line 1841  sub inst_directory_query {
    &escape($srch->{'srchtype'}),$homeserver);     &escape($srch->{'srchtype'}),$homeserver);
  my $host=&hostname($homeserver);   my $host=&hostname($homeserver);
  if ($queryid !~/^\Q$host\E\_/) {   if ($queryid !~/^\Q$host\E\_/) {
     &logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);      &logthis('institutional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.' in domain '.$udom);
     return;      return;
  }   }
  my $response = &get_query_reply($queryid);   my $response = &get_query_reply($queryid);
Line 2100  sub get_domain_defaults { Line 2114  sub get_domain_defaults {
                                   'requestcourses','inststatus',                                    'requestcourses','inststatus',
                                   'coursedefaults','usersessions',                                    'coursedefaults','usersessions',
                                   'requestauthor','selfenrollment',                                    'requestauthor','selfenrollment',
                                   'coursecategories','autoenroll'],$domain);                                    'coursecategories','autoenroll',
                                     'helpsettings'],$domain);
     my @coursetypes = ('official','unofficial','community','textbook');      my @coursetypes = ('official','unofficial','community','textbook');
     if (ref($domconfig{'defaults'}) eq 'HASH') {      if (ref($domconfig{'defaults'}) eq 'HASH') {
         $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};           $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
Line 2109  sub get_domain_defaults { Line 2124  sub get_domain_defaults {
         $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};          $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
         $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};          $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
         $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};          $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};
           $domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};
           $domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};
           $domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};
     } else {      } else {
         $domdefaults{'lang_def'} = &domain($domain,'lang_def');          $domdefaults{'lang_def'} = &domain($domain,'lang_def');
         $domdefaults{'auth_def'} = &domain($domain,'auth_def');          $domdefaults{'auth_def'} = &domain($domain,'auth_def');
Line 2228  sub get_domain_defaults { Line 2246  sub get_domain_defaults {
     if (ref($domconfig{'autoenroll'}) eq 'HASH') {      if (ref($domconfig{'autoenroll'}) eq 'HASH') {
         $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};          $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};
     }      }
       if (ref($domconfig{'helpsettings'}) eq 'HASH') {
           $domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'};
           if (ref($domconfig{'helpsettings'}{'adhoc'}) eq 'HASH') {
               $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};
           }
       }
     &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);      &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
     return %domdefaults;      return %domdefaults;
 }  }
Line 2854  sub externalssi { Line 2878  sub externalssi {
     }      }
 }  }
   
   # If the local copy of a replicated resource is outdated, trigger a
   # connection from the homeserver to flush the delayed queue. If no update
   # happens, remove local copies of outdated resource (and corresponding
   # metadata file).
   
   sub remove_stale_resfile {
       my ($url) = @_;
       my $removed;
       if ($url=~m{^/res/($match_domain)/($match_username)/}) {
           my $audom = $1;
           my $auname = $2;
           unless (($url =~ /\.\d+\.\w+$/) || ($url =~ m{^/res/lib/templates/})) {
               my $homeserver = &homeserver($auname,$audom);
               unless (($homeserver eq 'no_host') ||
                       (grep { $_ eq $homeserver } &current_machine_ids())) {
                   my $fname = &filelocation('',$url);
                   if (-e $fname) {
                       my $ua=new LWP::UserAgent;
                       $ua->timeout(5);
                       my $protocol = $protocol{$homeserver};
                       $protocol = 'http' if ($protocol ne 'https');
                       my $hostname = &hostname($homeserver);
                       if ($hostname) {
                           my $uri = $protocol.'://'.$hostname.'/raw/'.&declutter($url);
                           my $request=new HTTP::Request('HEAD',$uri);
                           my $response=$ua->request($request);
                           if ($response->is_success()) {
                               my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') );
                               my $locmodtime = (stat($fname))[9];
                               if ($locmodtime < $remmodtime) {
                                   my $stale;
                                   my $answer = &reply('pong',$homeserver);
                                   if ($answer eq $homeserver.':'.$perlvar{'lonHostID'}) {
                                       sleep(0.2);
                                       $locmodtime = (stat($fname))[9];
                                       if ($locmodtime < $remmodtime) {
                                           my $posstransfer = $fname.'.in.transfer';
                                           if ((-e $posstransfer) && ($remmodtime < (stat($posstransfer))[9])) {
                                               $removed = 1;
                                           } else {
                                               $stale = 1;
                                           }
                                       } else {
                                           $removed = 1;
                                       }
                                   } else {
                                       $stale = 1;
                                   }
                                   if ($stale) {
                                       unlink($fname);
                                       if ($uri!~/\.meta$/) {
                                           unlink($fname.'.meta');
                                       }
                                       &reply("unsub:$fname",$homeserver);
                                       $removed = 1;
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
       return $removed;
   }
   
 # -------------------------------- Allow a /uploaded/ URI to be vouched for  # -------------------------------- Allow a /uploaded/ URI to be vouched for
   
 sub allowuploaded {  sub allowuploaded {
Line 3182  sub process_coursefile { Line 3272  sub process_coursefile {
                                  $home);                                   $home);
             }              }
         } elsif ($action eq 'uploaddoc') {          } elsif ($action eq 'uploaddoc') {
             open(my $fh,'>'.$filepath.'/'.$fname);              open(my $fh,'>',$filepath.'/'.$fname);
             print $fh $env{'form.'.$source};              print $fh $env{'form.'.$source};
             close($fh);              close($fh);
             if ($parser eq 'parse') {              if ($parser eq 'parse') {
Line 3240  sub store_edited_file { Line 3330  sub store_edited_file {
     ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);      ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
     $fpath=$docudom.'/'.$docuname.'/'.$fpath;      $fpath=$docudom.'/'.$docuname.'/'.$fpath;
     my $filepath = &build_filepath($fpath);      my $filepath = &build_filepath($fpath);
     open(my $fh,'>'.$filepath.'/'.$fname);      open(my $fh,'>',$filepath.'/'.$fname);
     print $fh $content;      print $fh $content;
     close($fh);      close($fh);
     my $home=&homeserver($docuname,$docudom);      my $home=&homeserver($docuname,$docudom);
Line 3356  sub userfileupload { Line 3446  sub userfileupload {
                          '_'.$env{'user.domain'}.'/pending';                           '_'.$env{'user.domain'}.'/pending';
         } elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) {          } elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) {
             my ($docuname,$docudom);              my ($docuname,$docudom);
             if ($destudom) {              if ($destudom =~ /^$match_domain$/) {
                 $docudom = $destudom;                  $docudom = $destudom;
             } else {              } else {
                 $docudom = $env{'user.domain'};                  $docudom = $env{'user.domain'};
             }              }
             if ($destuname) {              if ($destuname =~ /^$match_username$/) { 
                 $docuname = $destuname;                  $docuname = $destuname;
             } else {              } else {
                 $docuname = $env{'user.name'};                  $docuname = $env{'user.name'};
Line 3391  sub userfileupload { Line 3481  sub userfileupload {
                 mkdir($fullpath,0777);                  mkdir($fullpath,0777);
             }              }
         }          }
         open(my $fh,'>'.$fullpath.'/'.$fname);          open(my $fh,'>',$fullpath.'/'.$fname);
         print $fh $env{'form.'.$formname};          print $fh $env{'form.'.$formname};
         close($fh);          close($fh);
         if ($context eq 'existingfile') {          if ($context eq 'existingfile') {
Line 3466  sub finishuserfileupload { Line 3556  sub finishuserfileupload {
   
 # Save the file  # Save the file
     {      {
  if (!open(FH,'>'.$filepath.'/'.$file)) {   if (!open(FH,'>',$filepath.'/'.$file)) {
     &logthis('Failed to create '.$filepath.'/'.$file);      &logthis('Failed to create '.$filepath.'/'.$file);
     print STDERR ('Failed to create '.$filepath.'/'.$file."\n");      print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
     return '/adm/notfound.html';      return '/adm/notfound.html';
Line 3524  sub finishuserfileupload { Line 3614  sub finishuserfileupload {
         my $input = $filepath.'/'.$file;          my $input = $filepath.'/'.$file;
         my $output = $filepath.'/'.'tn-'.$file;          my $output = $filepath.'/'.'tn-'.$file;
         my $thumbsize = $thumbwidth.'x'.$thumbheight;          my $thumbsize = $thumbwidth.'x'.$thumbheight;
         system("convert -sample $thumbsize $input $output");          my @args = ('convert','-sample',$thumbsize,$input,$output);
           system({$args[0]} @args);
         if (-e $filepath.'/'.'tn-'.$file) {          if (-e $filepath.'/'.'tn-'.$file) {
             $fetchthumb  = 1;               $fetchthumb  = 1; 
         }          }
Line 3908  sub flushcourselogs { Line 3999  sub flushcourselogs {
         }          }
     }      }
 #  #
 # Reverse lookup of domain roles (dc, ad, li, sc, au)  # Reverse lookup of domain roles (dc, ad, li, sc, dh, da, au)
 #  #
     my %domrolebuffer = ();      my %domrolebuffer = ();
     foreach my $entry (keys(%domainrolehash)) {      foreach my $entry (keys(%domainrolehash)) {
Line 3923  sub flushcourselogs { Line 4014  sub flushcourselogs {
         delete $domainrolehash{$entry};          delete $domainrolehash{$entry};
     }      }
     foreach my $dom (keys(%domrolebuffer)) {      foreach my $dom (keys(%domrolebuffer)) {
  my %servers = &get_servers($dom,'library');          my %servers;
           if (defined(&domain($dom,'primary'))) {
               my $primary=&domain($dom,'primary');
               my $hostname=&hostname($primary);
               $servers{$primary} = $hostname;
           } else {
               %servers = &get_servers($dom,'library');
           }
  foreach my $tryserver (keys(%servers)) {   foreach my $tryserver (keys(%servers)) {
     unless (&reply('domroleput:'.$dom.':'.      if (&reply('domroleput:'.$dom.':'.
    $domrolebuffer{$dom},$tryserver) eq 'ok') {                 $domrolebuffer{$dom},$tryserver) eq 'ok') {
           last;
       } else {
  &logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);   &logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);
     }      }
         }          }
Line 4046  sub userrolelog { Line 4146  sub userrolelog {
          {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}           {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
                     =$tend.':'.$tstart;                      =$tend.':'.$tstart;
     }      }
     if ($trole =~ /^(dc|ad|li|au|dg|sc)/ ) {      if ($trole =~ /^(dc|ad|li|au|dg|sc|dh|da)/ ) {
        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);         my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
        $domainrolehash         $domainrolehash
          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
Line 4273  sub get_my_roles { Line 4373  sub get_my_roles {
     return %returnhash;      return %returnhash;
 }  }
   
   sub get_all_adhocroles {
       my ($dom) = @_;
       my @roles_by_num = ();
       my %domdefaults = &get_domain_defaults($dom);
       my (%description,%access_in_dom,%access_info);
       if (ref($domdefaults{'adhocroles'}) eq 'HASH') {
           my $count = 0;
           my %domcurrent = %{$domdefaults{'adhocroles'}};
           my %ordered;
           foreach my $role (sort(keys(%domcurrent))) {
               my ($order,$desc,$access_in_dom);
               if (ref($domcurrent{$role}) eq 'HASH') {
                   $order = $domcurrent{$role}{'order'};
                   $desc = $domcurrent{$role}{'desc'};
                   $access_in_dom{$role} = $domcurrent{$role}{'access'};
                   $access_info{$role} = $domcurrent{$role}{$access_in_dom{$role}};
               }
               if ($order eq '') {
                   $order = $count;
               }
               $ordered{$order} = $role;
               if ($desc ne '') {
                   $description{$role} = $desc;
               } else {
                   $description{$role}= $role;
               }
               $count++;
           }
           foreach my $item (sort {$a <=> $b } (keys(%ordered))) {
               push(@roles_by_num,$ordered{$item});
           }
       }
       return (\@roles_by_num,\%description,\%access_in_dom,\%access_info);
   }
   
   sub get_my_adhocroles {
       my ($cid,$checkreg) = @_;
       my ($cdom,$cnum,%info,@possroles,$description,$roles_by_num);
       if ($env{'request.course.id'} eq $cid) {
           $cdom = $env{'course.'.$cid.'.domain'};
           $cnum = $env{'course.'.$cid.'.num'};
           $info{'internal.coursecode'} = $env{'course.'.$cid.'.internal.coursecode'};
       } elsif ($cid =~ /^($match_domain)_($match_courseid)$/) {
           $cdom = $1;
           $cnum = $2;
           %info = &Apache::lonnet::get('environment',['internal.coursecode'],
                                        $cdom,$cnum);
       }
       if (($info{'internal.coursecode'} ne '') && ($checkreg)) {
           my $user = $env{'user.name'}.':'.$env{'user.domain'};
           my %rosterhash = &get('classlist',[$user],$cdom,$cnum);
           if ($rosterhash{$user} ne '') {
               my $type = (split(/:/,$rosterhash{$user}))[5];
               return ([],{}) if ($type eq 'auto');
           }
       }
       if (($cdom ne '') && ($cnum ne ''))  {
           if (($env{"user.role.dh./$cdom/"}) || ($env{"user.role.da./$cdom/"})) {
               my $then=$env{'user.login.time'};
               my $update=$env{'user.update.time'};
               if (!$update) {
                   $update = $then;
               }
               my @liveroles;
               foreach my $role ('dh','da') {
                   if ($env{"user.role.$role./$cdom/"}) {
                       my ($tstart,$tend)=split(/\./,$env{"user.role.$role./$cdom/"});
                       my $limit = $update;
                       if ($env{'request.role'} eq "$role./$cdom/") {
                           $limit = $then;
                       }
                       my $activerole = 1;
                       if ($tstart && $tstart>$limit) { $activerole = 0; }
                       if ($tend   && $tend  <$limit) { $activerole = 0; }
                       if ($activerole) {
                           push(@liveroles,$role);
                       }
                   }
               }
               if (@liveroles) {
                   if (&homeserver($cnum,$cdom) ne 'no_host') {
                       my ($accessref,$accessinfo,%access_in_dom);
                       ($roles_by_num,$description,$accessref,$accessinfo) = &get_all_adhocroles($cdom);
                       if (ref($roles_by_num) eq 'ARRAY') {
                           if (@{$roles_by_num}) {
                               my %settings;
                               if ($env{'request.course.id'} eq $cid) {
                                   foreach my $envkey (keys(%env)) {
                                       if ($envkey =~ /^\Qcourse.$cid.\E(internal\.adhoc.+)$/) {
                                           $settings{$1} = $env{$envkey};
                                       }
                                   }
                               } else {
                                   %settings = &dump('environment',$cdom,$cnum,'internal\.adhoc');
                               }
                               my %setincrs;
                               if ($settings{'internal.adhocaccess'}) {
                                   map { $setincrs{$_} = 1; } split(/,/,$settings{'internal.adhocaccess'});
                               }
                               my @statuses;
                               if ($env{'environment.inststatus'}) {
                                   @statuses = split(/,/,$env{'environment.inststatus'});
                               }
                               my $user = $env{'user.name'}.':'.$env{'user.domain'};
                               if (ref($accessref) eq 'HASH') {
                                   %access_in_dom = %{$accessref};
                               }
                               foreach my $role (@{$roles_by_num}) {
                                   my ($curraccess,@okstatus,@personnel);
                                   if ($setincrs{$role}) {
                                       ($curraccess,my $rest) = split(/=/,$settings{'internal.adhoc.'.$role});
                                       if ($curraccess eq 'status') {
                                           @okstatus = split(/\&/,$rest);
                                       } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) {
                                           @personnel = split(/\&/,$rest);
                                       }
                                   } else {
                                       $curraccess = $access_in_dom{$role};
                                       if (ref($accessinfo) eq 'HASH') {
                                           if ($curraccess eq 'status') {
                                               if (ref($accessinfo->{$role}) eq 'ARRAY') {
                                                   @okstatus = @{$accessinfo->{$role}};
                                               }
                                           } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) {
                                               if (ref($accessinfo->{$role}) eq 'ARRAY') {
                                                   @personnel = @{$accessinfo->{$role}};
                                               }
                                           }
                                       }
                                   }
                                   if ($curraccess eq 'none') {
                                       next;
                                   } elsif ($curraccess eq 'all') {
                                       push(@possroles,$role);
                                   } elsif ($curraccess eq 'dh') {
                                       if (grep(/^dh$/,@liveroles)) {
                                           push(@possroles,$role);
                                       } else {
                                           next;
                                       }
                                   } elsif ($curraccess eq 'da') {
                                       if (grep(/^da$/,@liveroles)) {
                                           push(@possroles,$role);
                                       } else {
                                           next;
                                       }
                                   } elsif ($curraccess eq 'status') {
                                       if (@okstatus) {
                                           if (!@statuses) {
                                               if (grep(/^default$/,@okstatus)) {
                                                   push(@possroles,$role);
                                               }
                                           } else {
                                               foreach my $status (@okstatus) {
                                                   if (grep(/^\Q$status\E$/,@statuses)) {
                                                       push(@possroles,$role);
                                                       last;
                                                   }
                                               }
                                           }
                                       }
                                   } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) {
                                       if (grep(/^\Q$user\E$/,@personnel)) {
                                           if ($curraccess eq 'exc') {
                                               push(@possroles,$role);
                                           }
                                       } elsif ($curraccess eq 'inc') {
                                           push(@possroles,$role);
                                       }
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
       unless (ref($description) eq 'HASH') {
           if (ref($roles_by_num) eq 'ARRAY') {
               my %desc;
               map { $desc{$_} = $_; } (@{$roles_by_num});
               $description = \%desc;
           } else {
               $description = {};
           }
       }
       return (\@possroles,$description);
   }
   
 # ----------------------------------------------------- Frontpage Announcements  # ----------------------------------------------------- Frontpage Announcements
 #  #
 #  #
Line 4286  sub postannounce { Line 4575  sub postannounce {
   
 sub getannounce {  sub getannounce {
   
     if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {      if (open(my $fh,"<",$perlvar{'lonDocRoot'}.'/announcement.txt')) {
  my $announcement='';   my $announcement='';
  while (my $line = <$fh>) { $announcement .= $line; }   while (my $line = <$fh>) { $announcement .= $line; }
  close($fh);   close($fh);
Line 4513  sub get_domain_roles { Line 4802  sub get_domain_roles {
     return %personnel;      return %personnel;
 }  }
   
   sub get_active_domroles {
       my ($dom,$roles) = @_;
       return () unless (ref($roles) eq 'ARRAY');
       my $now = time;
       my %dompersonnel = &get_domain_roles($dom,$roles,$now,$now);
       my %domroles;
       foreach my $server (keys(%dompersonnel)) {
           foreach my $user (sort(keys(%{$dompersonnel{$server}}))) {
               my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,$user);
               $domroles{$uname.':'.$udom} = $dompersonnel{$server}{$user};
           }
       }
       return %domroles;
   }
   
 # ----------------------------------------------------------- Interval timing   # ----------------------------------------------------------- Interval timing 
   
 {  {
Line 4580  sub set_first_access { Line 4884  sub set_first_access {
                         'course.'.$courseid.'.timerinterval.'.$res => $interval,                          'course.'.$courseid.'.timerinterval.'.$res => $interval,
                      }                       }
                   );                    );
               if (($cachedtime) && (abs($start-$cachedtime) < 5)) {
                   $cachedtimes{"$courseid\0$res"} = $start;
               }
         }          }
         return $putres;          return $putres;
     }      }
Line 5451  sub rolesinit { Line 5758  sub rolesinit {
         }          }
     }      }
   
     @userroles{'user.author', 'user.adv'} = &set_userprivs(\%userroles,      @userroles{'user.author','user.adv','user.rar'} = &set_userprivs(\%userroles,
         \%allroles, \%allgroups);                                                            \%allroles, \%allgroups);
     $env{'user.adv'} = $userroles{'user.adv'};      $env{'user.adv'} = $userroles{'user.adv'};
       $env{'user.rar'} = $userroles{'user.rar'};
   
     return (\%userroles,\%firstaccenv,\%timerintenv);      return (\%userroles,\%firstaccenv,\%timerintenv);
 }  }
Line 5489  sub custom_roleprivs { Line 5797  sub custom_roleprivs {
                     $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;                      $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
                 }                  }
                 if (($trest ne '') && (defined($coursepriv))) {                  if (($trest ne '') && (defined($coursepriv))) {
                       if ($trole =~ m{^cr/$tdomain/$tdomain\Q-domainconfig\E/([^/]+)$}) {
                           my $rolename = $1;
                           $coursepriv = &course_adhocrole_privs($rolename,$tdomain,$trest,$coursepriv);
                       }
                     $$allroles{'cm.'.$area}.=':'.$coursepriv;                      $$allroles{'cm.'.$area}.=':'.$coursepriv;
                     $$allroles{$spec.'.'.$area}.=':'.$coursepriv;                      $$allroles{$spec.'.'.$area}.=':'.$coursepriv;
                 }                  }
Line 5497  sub custom_roleprivs { Line 5809  sub custom_roleprivs {
     }      }
 }  }
   
   sub course_adhocrole_privs {
       my ($rolename,$cdom,$cnum,$coursepriv) = @_;
       my %overrides = &get('environment',["internal.adhocpriv.$rolename"],$cdom,$cnum);
       if ($overrides{"internal.adhocpriv.$rolename"}) {
           my (%currprivs,%storeprivs);
           foreach my $item (split(/:/,$coursepriv)) {
               my ($priv,$restrict) = split(/\&/,$item);
               $currprivs{$priv} = $restrict;
           }
           my (%possadd,%possremove,%full);
           foreach my $item (split(/\:/,$Apache::lonnet::pr{'cr:c'})) {
               my ($priv,$restrict)=split(/\&/,$item);
               $full{$priv} = $restrict;
           }
           foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) {
                next if ($item eq '');
                my ($rule,$rest) = split(/=/,$item);
                next unless (($rule eq 'off') || ($rule eq 'on'));
                foreach my $priv (split(/:/,$rest)) {
                    if ($priv ne '') {
                        if ($rule eq 'off') {
                            $possremove{$priv} = 1;
                        } else {
                            $possadd{$priv} = 1;
                        }
                    }
                }
            }
            foreach my $priv (sort(keys(%full))) {
                if (exists($currprivs{$priv})) {
                    unless (exists($possremove{$priv})) {
                        $storeprivs{$priv} = $currprivs{$priv};
                    }
                } elsif (exists($possadd{$priv})) {
                    $storeprivs{$priv} = $full{$priv};
                }
            }
            $coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs)));
        }
        return $coursepriv;
   }
   
 sub group_roleprivs {  sub group_roleprivs {
     my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;      my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
     my $access = 1;      my $access = 1;
Line 5531  sub set_userprivs { Line 5885  sub set_userprivs {
     my ($userroles,$allroles,$allgroups,$groups_roles) = @_;       my ($userroles,$allroles,$allgroups,$groups_roles) = @_; 
     my $author=0;      my $author=0;
     my $adv=0;      my $adv=0;
       my $rar=0;
     my %grouproles = ();      my %grouproles = ();
     if (keys(%{$allgroups}) > 0) {      if (keys(%{$allgroups}) > 0) {
         my @groupkeys;           my @groupkeys; 
Line 5578  sub set_userprivs { Line 5933  sub set_userprivs {
                     $thesepriv{$privilege}.=$restrictions;                      $thesepriv{$privilege}.=$restrictions;
                 }                  }
                 if ($thesepriv{'adv'} eq 'F') { $adv=1; }                  if ($thesepriv{'adv'} eq 'F') { $adv=1; }
                   if ($thesepriv{'rar'} eq 'F') { $rar=1; }
             }              }
         }          }
         my $thesestr='';          my $thesestr='';
Line 5586  sub set_userprivs { Line 5942  sub set_userprivs {
  }   }
         $userroles->{'user.priv.'.$role} = $thesestr;          $userroles->{'user.priv.'.$role} = $thesestr;
     }      }
     return ($author,$adv);      return ($author,$adv,$rar);
 }  }
   
 sub role_status {  sub role_status {
Line 5631  sub role_status { Line 5987  sub role_status {
                                 push(@rolecodes,$$role);                                  push(@rolecodes,$$role);
                                 &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);                                  &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
                             }                              }
                             my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles);                              my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%allroles,\%allgroups,
                                                                      \%groups_roles);
                             &appenv(\%userroles,\@rolecodes);                              &appenv(\%userroles,\@rolecodes);
                             &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);                              &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
                         }                          }
                     }                      }
                     $$tstatus = 'is';                      $$tstatus = 'is';
Line 5709  sub delete_env_groupprivs { Line 6066  sub delete_env_groupprivs {
 }  }
   
 sub check_adhoc_privs {  sub check_adhoc_privs {
     my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;      my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller,$sec) = @_;
     my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;      my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
       if ($sec) {
           $cckey .= '/'.$sec;
       }
     my $setprivs;      my $setprivs;
     if ($env{$cckey}) {      if ($env{$cckey}) {
         my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);          my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
         &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);          &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
         unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {          unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {
             &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);              &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec);
             $setprivs = 1;              $setprivs = 1;
         }          }
     } else {      } else {
         &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);          &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec);
         $setprivs = 1;          $setprivs = 1;
     }      }
     return $setprivs;      return $setprivs;
 }  }
   
 sub set_adhoc_privileges {  sub set_adhoc_privileges {
 # role can be cc or ca  # role can be cc, ca, or cr/<dom>/<dom>-domainconfig/role
     my ($dcdom,$pickedcourse,$role,$caller) = @_;      my ($dcdom,$pickedcourse,$role,$caller,$sec) = @_;
     my $area = '/'.$dcdom.'/'.$pickedcourse;      my $area = '/'.$dcdom.'/'.$pickedcourse;
       if ($sec ne '') {
           $area .= '/'.$sec;
       }
     my $spec = $role.'.'.$area;      my $spec = $role.'.'.$area;
     my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},      my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
                                   $env{'user.name'},1);                                    $env{'user.name'},1);
     my %ccrole = ();      my %rolehash = ();
     &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);      if ($role =~ m{^\Qcr/$dcdom/$dcdom\E\-domainconfig/(\w+)$}) {
     my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);          my $rolename = $1;
           &custom_roleprivs(\%rolehash,$role,$dcdom,$pickedcourse,$spec,$area);
           my %domdef = &get_domain_defaults($dcdom);
           if (ref($domdef{'adhocroles'}) eq 'HASH') {
               if (ref($domdef{'adhocroles'}{$rolename}) eq 'HASH') {
                   &appenv({'request.role.desc' => $domdef{'adhocroles'}{$rolename}{'desc'},});
               }
           }
       } else {
           &standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area);
       }
       my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash);
     &appenv(\%userroles,[$role,'cm']);      &appenv(\%userroles,[$role,'cm']);
     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);      &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
     unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {      unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {
         &appenv( {'request.role'        => $spec,          &appenv( {'request.role'        => $spec,
                   'request.role.domain' => $dcdom,                    'request.role.domain' => $dcdom,
                   'request.course.sec'  => ''                    'request.course.sec'  => $sec, 
                  }                   }
                );                 );
         my $tadv=0;          my $tadv=0;
Line 6123  sub tmpget { Line 6497  sub tmpget {
     if (!defined($server)) { $server = $perlvar{'lonHostID'}; }      if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
     my $rep=&reply("tmpget:$token",$server);      my $rep=&reply("tmpget:$token",$server);
     my %returnhash;      my %returnhash;
       if ($rep =~ /^(con_lost|error|no_such_host)/i) {
           return %returnhash;
       }
     foreach my $item (split(/\&/,$rep)) {      foreach my $item (split(/\&/,$rep)) {
  my ($key,$value)=split(/=/,$item);   my ($key,$value)=split(/=/,$item);
         next if ($key =~ /^error: 2 /);  
  $returnhash{&unescape($key)}=&thaw_unescape($value);   $returnhash{&unescape($key)}=&thaw_unescape($value);
     }      }
     return %returnhash;      return %returnhash;
Line 7308  sub constructaccess { Line 7684  sub constructaccess {
     my ($ownername,$ownerdomain,$ownerhome);      my ($ownername,$ownerdomain,$ownerhome);
   
     ($ownerdomain,$ownername) =      ($ownerdomain,$ownername) =
         ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)/});          ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)(?:/|$)});
   
 # The URL does not really point to any authorspace, forget it  # The URL does not really point to any authorspace, forget it
     unless (($ownername) && ($ownerdomain)) { return ''; }      unless (($ownername) && ($ownerdomain)) { return ''; }
Line 7646  sub get_symb_from_alias { Line 8022  sub get_symb_from_alias {
   
 sub definerole {  sub definerole {
   if (allowed('mcr','/')) {    if (allowed('mcr','/')) {
     my ($rolename,$sysrole,$domrole,$courole)=@_;      my ($rolename,$sysrole,$domrole,$courole,$uname,$udom)=@_;
     foreach my $role (split(':',$sysrole)) {      foreach my $role (split(':',$sysrole)) {
  my ($crole,$cqual)=split(/\&/,$role);   my ($crole,$cqual)=split(/\&/,$role);
         if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }          if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
Line 7674  sub definerole { Line 8050  sub definerole {
             }              }
         }          }
     }      }
       my $uhome;
       if (($uname ne '') && ($udom ne '')) {
           $uhome = &homeserver($uname,$udom);
           return $uhome if ($uhome eq 'no_host');
       } else {
           $uname = $env{'user.name'};
           $udom = $env{'user.domain'};
           $uhome = $env{'user.home'};
       }
     my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".      my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
                 "$env{'user.domain'}:$env{'user.name'}:".                  "$udom:$uname:rolesdef_$rolename=".
         "rolesdef_$rolename=".  
                 escape($sysrole.'_'.$domrole.'_'.$courole);                  escape($sysrole.'_'.$domrole.'_'.$courole);
     return reply($command,$env{'user.home'});      return reply($command,$uhome);
   } else {    } else {
     return 'refused';      return 'refused';
   }    }
Line 7783  sub fetch_enrollment_query { Line 8167  sub fetch_enrollment_query {
         &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum);           &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); 
         return 'error: '.$queryid;          return 'error: '.$queryid;
     }      }
     my $reply = &get_query_reply($queryid,$sleep.$loopmax);      my $reply = &get_query_reply($queryid,$sleep,$loopmax);
     my $tries = 1;      my $tries = 1;
     while (($reply=~/^timeout/) && ($tries < $maxtries)) {      while (($reply=~/^timeout/) && ($tries < $maxtries)) {
         $reply = &get_query_reply($queryid,$sleep,$loopmax);          $reply = &get_query_reply($queryid,$sleep,$loopmax);
Line 7793  sub fetch_enrollment_query { Line 8177  sub fetch_enrollment_query {
         &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);          &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
     } else {      } else {
         my @responses = split(/:/,$reply);          my @responses = split(/:/,$reply);
         if ($homeserver eq $perlvar{'lonHostID'}) {          if (grep { $_ eq $homeserver } &current_machine_ids()) {
             foreach my $line (@responses) {              foreach my $line (@responses) {
                 my ($key,$value) = split(/=/,$line,2);                  my ($key,$value) = split(/=/,$line,2);
                 $$replyref{$key} = $value;                  $$replyref{$key} = $value;
Line 7811  sub fetch_enrollment_query { Line 8195  sub fetch_enrollment_query {
                         if ($xml_classlist =~ /^error/) {                          if ($xml_classlist =~ /^error/) {
                             &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);                              &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
                         } else {                          } else {
                             if ( open(FILE,">$destname") ) {                              if ( open(FILE,">",$destname) ) {
                                 print FILE &unescape($xml_classlist);                                  print FILE &unescape($xml_classlist);
                                 close(FILE);                                  close(FILE);
                             } else {                              } else {
Line 7840  sub get_query_reply { Line 8224  sub get_query_reply {
     for (1..$loopmax) {      for (1..$loopmax) {
  sleep($sleep);   sleep($sleep);
         if (-e $replyfile.'.end') {          if (-e $replyfile.'.end') {
     if (open(my $fh,$replyfile)) {      if (open(my $fh,"<",$replyfile)) {
  $reply = join('',<$fh>);   $reply = join('',<$fh>);
  close($fh);   close($fh);
    } else { return 'error: reply_file_error'; }     } else { return 'error: reply_file_error'; }
Line 8232  sub auto_validate_class_sec { Line 8616  sub auto_validate_class_sec {
     return $response;      return $response;
 }  }
   
   sub auto_validate_instclasses {
       my ($cdom,$cnum,$owners,$classesref) = @_;
       my ($homeserver,%validations);
       $homeserver = &homeserver($cnum,$cdom);
       unless ($homeserver eq 'no_host') {
           my $ownerlist;
           if (ref($owners) eq 'ARRAY') {
               $ownerlist = join(',',@{$owners});
           } else {
               $ownerlist = $owners;
           }
           if (ref($classesref) eq 'HASH') {
               my $classes = &freeze_escape($classesref);
               my $response=&reply('autovalidateinstclasses:'.&escape($ownerlist).
                                   ':'.$cdom.':'.$classes,$homeserver);
               unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
                   my @items = split(/&/,$response);
                   foreach my $item (@items) {
                       my ($key,$value) = split('=',$item);
                       $validations{&unescape($key)} = &thaw_unescape($value);
                   }
               }
           }
       }
       return %validations;
   }
   
 sub auto_crsreq_update {  sub auto_crsreq_update {
     my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,      my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,
         $code,$accessstart,$accessend,$inbound) = @_;          $code,$accessstart,$accessend,$inbound) = @_;
Line 8725  sub assignrole { Line 9136  sub assignrole {
             &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,              &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                            $selfenroll,$context);                             $selfenroll,$context);
         } 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 'au') || ($role eq 'dc') || ($role eq 'dh') ||
                    ($role eq 'da')) {
             &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,              &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                            $context);                             $context);
         } elsif (($role eq 'ca') || ($role eq 'aa')) {          } elsif (($role eq 'ca') || ($role eq 'aa')) {
Line 9322  sub generate_coursenum { Line 9734  sub generate_coursenum {
 sub is_course {  sub is_course {
     my ($cdom, $cnum) = scalar(@_) == 1 ?       my ($cdom, $cnum) = scalar(@_) == 1 ? 
          ($_[0] =~ /^($match_domain)_($match_courseid)$/)  :  @_;           ($_[0] =~ /^($match_domain)_($match_courseid)$/)  :  @_;
       return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/));
     return unless $cdom and $cnum;      my $uhome=&homeserver($cnum,$cdom);
       my $iscourse;
     my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,      if (grep { $_ eq $uhome } current_machine_ids()) {
         '.');          $iscourse = &LONCAPA::Lond::is_course($cdom,$cnum);
       } else {
     return unless(exists($courses{$cdom.'_'.$cnum}));          my $hashid = $cdom.':'.$cnum;
           ($iscourse,my $cached) = &is_cached_new('iscourse',$hashid);
           unless (defined($cached)) {
               my %courses = &courseiddump($cdom, '.', 1, '.', '.',
                                           $cnum,undef,undef,'.');
               $iscourse = 0;
               if (exists($courses{$cdom.'_'.$cnum})) {
                   $iscourse = 1;
               }
               &do_cache_new('iscourse',$hashid,$iscourse,3600);
           }
       }
       return unless($iscourse);
     return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;      return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
 }  }
   
Line 9464  sub save_selected_files { Line 9888  sub save_selected_files {
     my ($user, $path, @files) = @_;      my ($user, $path, @files) = @_;
     my $filename = $user."savedfiles";      my $filename = $user."savedfiles";
     my @other_files = &files_not_in_path($user, $path);      my @other_files = &files_not_in_path($user, $path);
     open (OUT, '>'.$tmpdir.$filename);      open (OUT,'>',LONCAPA::tempdir().$filename);
     foreach my $file (@files) {      foreach my $file (@files) {
         print (OUT $env{'form.currentpath'}.$file."\n");          print (OUT $env{'form.currentpath'}.$file."\n");
     }      }
Line 9478  sub save_selected_files { Line 9902  sub save_selected_files {
 sub clear_selected_files {  sub clear_selected_files {
     my ($user) = @_;      my ($user) = @_;
     my $filename = $user."savedfiles";      my $filename = $user."savedfiles";
     open (OUT, '>'.LONCAPA::tempdir().$filename);      open (OUT,'>',LONCAPA::tempdir().$filename);
     print (OUT undef);      print (OUT undef);
     close (OUT);      close (OUT);
     return ("ok");          return ("ok");    
Line 9488  sub files_in_path { Line 9912  sub files_in_path {
     my ($user, $path) = @_;      my ($user, $path) = @_;
     my $filename = $user."savedfiles";      my $filename = $user."savedfiles";
     my %return_files;      my %return_files;
     open (IN, '<'.LONCAPA::tempdir().$filename);      open (IN,'<',LONCAPA::tempdir().$filename);
     while (my $line_in = <IN>) {      while (my $line_in = <IN>) {
         chomp ($line_in);          chomp ($line_in);
         my @paths_and_file = split (m!/!, $line_in);          my @paths_and_file = split (m!/!, $line_in);
Line 9510  sub files_not_in_path { Line 9934  sub files_not_in_path {
     my $filename = $user."savedfiles";      my $filename = $user."savedfiles";
     my @return_files;      my @return_files;
     my $path_part;      my $path_part;
     open(IN, '<'.LONCAPA::.$filename);      open(IN, '<',LONCAPA::tempdir().$filename);
     while (my $line = <IN>) {      while (my $line = <IN>) {
         #ok, I know it's clunky, but I want it to work          #ok, I know it's clunky, but I want it to work
         my @paths_and_file = split(m|/|, $line);          my @paths_and_file = split(m|/|, $line);
Line 10644  sub add_prefix_and_part { Line 11068  sub add_prefix_and_part {
   
 my %metaentry;  my %metaentry;
 my %importedpartids;  my %importedpartids;
   my %importedrespids;
 sub metadata {  sub metadata {
     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;      my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
     $uri=&declutter($uri);      $uri=&declutter($uri);
Line 10671  sub metadata { Line 11096  sub metadata {
     }      }
     {      {
 # Imported parts would go here  # Imported parts would go here
         my %importedids=();          my @origfiletagids=();
         my @origfileimportpartids=();  
         my $importedparts=0;          my $importedparts=0;
   
   # Imported responseids would go here
           my $importedresponses=0;
 #  #
 # Is this a recursive call for a library?  # Is this a recursive call for a library?
 #  #
Line 10768  sub metadata { Line 11195  sub metadata {
                         my $dir=$filename;                          my $dir=$filename;
                         $dir=~s|[^/]*$||;                          $dir=~s|[^/]*$||;
                         $location=&filelocation($dir,$location);                          $location=&filelocation($dir,$location);
                          
                           my $importid=$token->[2]->{'id'};
                         my $importmode=$token->[2]->{'importmode'};                          my $importmode=$token->[2]->{'importmode'};
   #
   # Check metadata for imported file to
   # see if it contained response items
   #
                           my %currmetaentry = %metaentry;
                           my $libresponseorder = &metadata($location,'responseorder');
                           my $origfile;
                           if ($libresponseorder ne '') {
                               if ($#origfiletagids<0) {
                                   undef(%importedrespids);
                                   undef(%importedpartids);
                               }
                               @{$importedrespids{$importid}} = split(/\s*,\s*/,$libresponseorder);
                               if (@{$importedrespids{$importid}} > 0) {
                                   $importedresponses = 1;
   # We need to get the original file and the imported file to get the response order correct
   # Load and inspect original file
                                   if ($#origfiletagids<0) {
                                       my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
                                       $origfile=&getfile($origfilelocation);
                                       @origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                                   }
                               }
                           }
   # Do not overwrite contents of %metaentry hash for resource itself with 
   # hash populated for imported library file
                           %metaentry = %currmetaentry;
                           undef(%currmetaentry);
                         if ($importmode eq 'problem') {                          if ($importmode eq 'problem') {
 # Import as problem/response  # Import as problem/response
                            $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});                             $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
Line 10778  sub metadata { Line 11234  sub metadata {
                            $importedparts=1;                             $importedparts=1;
 # We need to get the original file and the imported file to get the part order correct  # We need to get the original file and the imported file to get the part order correct
 # Good news: we do not need to worry about nested libraries, since parts cannot be nested  # Good news: we do not need to worry about nested libraries, since parts cannot be nested
 # Load and inspect original file  # Load and inspect original file if we didn't do that already
                            if ($#origfileimportpartids<0) {                             if ($#origfiletagids<0) {
                               undef(%importedpartids);                                 undef(%importedrespids);
                               my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);                                 undef(%importedpartids);
                               my $origfile=&getfile($origfilelocation);                                 if ($origfile eq '') {
                               @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);                                     my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
                                      $origfile=&getfile($origfilelocation);
                                      @origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                                  }
                            }                             }
   
 # Load and inspect imported file  # Load and inspect imported file
Line 10897  sub metadata { Line 11356  sub metadata {
     grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));      grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
  $metaentry{':packages'} = join(',',@uniq_packages);   $metaentry{':packages'} = join(',',@uniq_packages);
   
         if ($importedparts) {          if (($importedresponses) || ($importedparts)) {
               if ($importedparts) {
 # We had imported parts and need to rebuild partorder  # We had imported parts and need to rebuild partorder
            $metaentry{':partorder'}='';                  $metaentry{':partorder'}='';
            $metathesekeys{'partorder'}=1;                  $metathesekeys{'partorder'}=1;
            for (my $index=0;$index<$#origfileimportpartids;$index+=2) {              }
                if ($origfileimportpartids[$index] eq 'part') {              if ($importedresponses) {
 # original part, part of the problem  # We had imported responses and need to rebuild responseorder
                   $metaentry{':partorder'}.=','.$origfileimportpartids[$index+1];                  $metaentry{':responseorder'}='';
                } else {                  $metathesekeys{'responseorder'}=1;
 # we have imported parts at this position              }
                   $metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]};              for (my $index=0;$index<$#origfiletagids;$index+=2) {
                }                  my $origid = $origfiletagids[$index+1];
            }                  if ($origfiletagids[$index] eq 'part') {
            $metaentry{':partorder'}=~s/^\,//;  # Original part, part of the problem
                       if ($importedparts) {
                           $metaentry{':partorder'}.=','.$origid;
                       }
                   } elsif ($origfiletagids[$index] eq 'import') {
                       if ($importedparts) {
   # We have imported parts at this position
                           $metaentry{':partorder'}.=','.$importedpartids{$origid};
                       }
                       if ($importedresponses) {
   # We have imported responses at this position
                           if (ref($importedrespids{$origid}) eq 'ARRAY') {
                               $metaentry{':responseorder'}.=','.join(',',map { $origid.'_'.$_ } @{$importedrespids{$origid}});
                           }
                       }
                   } else {
   # Original response item, part of the problem
                       if ($importedresponses) {
                           $metaentry{':responseorder'}.=','.$origid;
                       }
                   }
               }
               if ($importedparts) {
                   $metaentry{':partorder'}=~s/^\,//;
               }
               if ($importedresponses) {
                   $metaentry{':responseorder'}=~s/^\,//;
               }
         }          }
   
  $metaentry{':keys'} = join(',',keys(%metathesekeys));   $metaentry{':keys'} = join(',',keys(%metathesekeys));
Line 11998  sub readfile { Line 12485  sub readfile {
     my $file = shift;      my $file = shift;
     if ( (! -e $file ) || ($file eq '') ) { return -1; };      if ( (! -e $file ) || ($file eq '') ) { return -1; };
     my $fh;      my $fh;
     open($fh,"<$file");      open($fh,"<",$file);
     my $a='';      my $a='';
     while (my $line = <$fh>) { $a .= $line; }      while (my $line = <$fh>) { $a .= $line; }
     return $a;      return $a;
Line 12111  sub machine_ids { Line 12598  sub machine_ids {
   
 sub additional_machine_domains {  sub additional_machine_domains {
     my @domains;      my @domains;
     open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");      open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab");
     while( my $line = <$fh>) {      while( my $line = <$fh>) {
         $line =~ s/\s//g;          $line =~ s/\s//g;
         push(@domains,$line);          push(@domains,$line);
Line 12255  sub get_dns { Line 12742  sub get_dns {
     }      }
   
     my %alldns;      my %alldns;
     open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");      if (open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab")) {
     foreach my $dns (<$config>) {          foreach my $dns (<$config>) {
  next if ($dns !~ /^\^(\S*)/x);      next if ($dns !~ /^\^(\S*)/x);
         my $line = $1;              my $line = $1;
         my ($host,$protocol) = split(/:/,$line);              my ($host,$protocol) = split(/:/,$line);
         if ($protocol ne 'https') {              if ($protocol ne 'https') {
             $protocol = 'http';                  $protocol = 'http';
               }
       $alldns{$host} = $protocol;
         }          }
  $alldns{$host} = $protocol;          close($config);
     }      }
     while (%alldns) {      while (%alldns) {
  my ($dns) = sort { $b cmp $a } keys(%alldns);   my ($dns) = sort { $b cmp $a } keys(%alldns);
Line 12283  sub get_dns { Line 12772  sub get_dns {
     close($config);      close($config);
     my $which = (split('/',$url))[3];      my $which = (split('/',$url))[3];
     &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");      &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
     open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");      open($config,"<","$perlvar{'lonTabDir'}/dns_$which.tab");
     my @content = <$config>;      my @content = <$config>;
     &$func(\@content,$hashref);      &$func(\@content,$hashref);
     return;      return;
Line 12376  sub fetch_dns_checksums { Line 12865  sub fetch_dns_checksums {
  my ($ignore_cache,$nocache) = @_;   my ($ignore_cache,$nocache) = @_;
  &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache);   &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache);
  my $fh;   my $fh;
  if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {   if (open($fh,"<",$perlvar{'lonTabDir'}.'/domain.tab')) {
     my @lines = <$fh>;      my @lines = <$fh>;
     &parse_domain_tab(\@lines);      &parse_domain_tab(\@lines);
  }   }
Line 12428  sub fetch_dns_checksums { Line 12917  sub fetch_dns_checksums {
     my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);      my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);
     $name=~s/\s//g;      $name=~s/\s//g;
     if ($id && $domain && $role && $name) {      if ($id && $domain && $role && $name) {
                   if ((exists($hostname{$id})) && ($hostname{$id} ne '')) {
                       my $curr = $hostname{$id};
                       my $skip;
                       if (ref($name_to_host{$curr}) eq 'ARRAY') {
                           if (($curr eq $name) && (@{$name_to_host{$curr}} == 1)) {
                               $skip = 1;
                           } else {
                               @{$name_to_host{$curr}} = grep { $_ ne $id } @{$name_to_host{$curr}};
                           }
                       }
                       unless ($skip) {
                           push(@{$name_to_host{$name}},$id);
                       }
                   } else {
                       push(@{$name_to_host{$name}},$id);
                   }
  $hostname{$id}=$name;   $hostname{$id}=$name;
  push(@{$name_to_host{$name}}, $id);  
  $hostdom{$id}=$domain;   $hostdom{$id}=$domain;
  if ($role eq 'library') { $libserv{$id}=$name; }   if ($role eq 'library') { $libserv{$id}=$name; }
                 if (defined($protocol)) {                  if (defined($protocol)) {
Line 12462  sub fetch_dns_checksums { Line 12966  sub fetch_dns_checksums {
     sub load_hosts_tab {      sub load_hosts_tab {
  my ($ignore_cache,$nocache) = @_;   my ($ignore_cache,$nocache) = @_;
  &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache);   &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache);
  open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");   open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab");
  my @config = <$config>;   my @config = <$config>;
  &parse_hosts_tab(\@config);   &parse_hosts_tab(\@config);
  close($config);   close($config);
Line 12728  sub all_loncaparevs { Line 13232  sub all_loncaparevs {
 {  {
     sub load_loncaparevs {      sub load_loncaparevs {
         if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {          if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {
             if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {              if (open(my $config,"<","$perlvar{'lonTabDir'}/loncaparevs.tab")) {
                 while (my $configline=<$config>) {                  while (my $configline=<$config>) {
                     chomp($configline);                      chomp($configline);
                     my ($hostid,$loncaparev)=split(/:/,$configline);                      my ($hostid,$loncaparev)=split(/:/,$configline);
Line 12744  sub all_loncaparevs { Line 13248  sub all_loncaparevs {
 {  {
     sub load_serverhomeIDs {      sub load_serverhomeIDs {
         if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {          if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {
             if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {              if (open(my $config,"<","$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {
                 while (my $configline=<$config>) {                  while (my $configline=<$config>) {
                     chomp($configline);                      chomp($configline);
                     my ($name,$id)=split(/:/,$configline);                      my ($name,$id)=split(/:/,$configline);
Line 12769  BEGIN { Line 13273  BEGIN {
   
 # ------------------------------------------------------ Read spare server file  # ------------------------------------------------------ Read spare server file
 {  {
     open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");      open(my $config,"<","$perlvar{'lonTabDir'}/spare.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
        chomp($configline);         chomp($configline);
Line 12783  BEGIN { Line 13287  BEGIN {
 }  }
 # ------------------------------------------------------------ Read permissions  # ------------------------------------------------------------ Read permissions
 {  {
     open(my $config,"<$perlvar{'lonTabDir'}/roles.tab");      open(my $config,"<","$perlvar{'lonTabDir'}/roles.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
  chomp($configline);   chomp($configline);
Line 12797  BEGIN { Line 13301  BEGIN {
   
 # -------------------------------------------- Read plain texts for permissions  # -------------------------------------------- Read plain texts for permissions
 {  {
     open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab");      open(my $config,"<","$perlvar{'lonTabDir'}/rolesplain.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
  chomp($configline);   chomp($configline);
Line 12817  BEGIN { Line 13321  BEGIN {
   
 # ---------------------------------------------------------- Read package table  # ---------------------------------------------------------- Read package table
 {  {
     open(my $config,"<$perlvar{'lonTabDir'}/packages.tab");      open(my $config,"<","$perlvar{'lonTabDir'}/packages.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
  if ($configline !~ /\S/ || $configline=~/^#/) { next; }   if ($configline !~ /\S/ || $configline=~/^#/) { next; }
Line 12863  BEGIN { Line 13367  BEGIN {
 # ---------------------------------------------------------- Read managers table  # ---------------------------------------------------------- Read managers table
 {  {
     if (-e "$perlvar{'lonTabDir'}/managers.tab") {      if (-e "$perlvar{'lonTabDir'}/managers.tab") {
         if (open(my $config,"<$perlvar{'lonTabDir'}/managers.tab")) {          if (open(my $config,"<","$perlvar{'lonTabDir'}/managers.tab")) {
             while (my $configline=<$config>) {              while (my $configline=<$config>) {
                 chomp($configline);                  chomp($configline);
                 next if ($configline =~ /^\#/);                  next if ($configline =~ /^\#/);
Line 13217  in which case the null string is returne Line 13721  in which case the null string is returne
   
 =item *  =item *
   
 definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom  definerole($rolename,$sysrole,$domrole,$courole,$uname,$udom) : define role;
 role rolename set privileges in format of lonTabs/roles.tab for system, domain,  define a custom role rolename set privileges in format of lonTabs/roles.tab
 and course level  for system, domain, and course level. $uname and $udom are optional (current
   user's username and domain will be used when either of $uname or $udom are absent.
   
 =item *  =item *
   
Removed from v.1.1172.2.81  
changed lines
  Added in v.1.1172.2.99

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