[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.986 and 1.1048

version 1.986, 2009/02/10 11:15:16 version 1.1048, 2009/12/30 18:01:17
Line 74  use strict; Line 74  use strict;
 use LWP::UserAgent();  use LWP::UserAgent();
 use HTTP::Date;  use HTTP::Date;
 use Image::Magick;  use Image::Magick;
 use IO::Socket;  
   
 # use Date::Parse;  
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir  use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
             $_64bit %env %protocol);              $_64bit %env %protocol);
   
Line 94  use Time::HiRes qw( gettimeofday tv_inte Line 92  use Time::HiRes qw( gettimeofday tv_inte
 use Cache::Memcached;  use Cache::Memcached;
 use Digest::MD5;  use Digest::MD5;
 use Math::Random;  use Math::Random;
   use File::MMagic;
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
   
Line 198  sub get_server_timezone { Line 197  sub get_server_timezone {
     }      }
 }  }
   
   sub get_server_loncaparev {
       my ($dom,$lonhost) = @_;
       if (defined($lonhost)) {
           if (!defined(&hostname($lonhost))) {
               undef($lonhost);
           }
       }
       if (!defined($lonhost)) {
           if (defined(&domain($dom,'primary'))) {
               $lonhost=&domain($dom,'primary');
               if ($lonhost eq 'no_host') {
                   undef($lonhost);
               }
           }
       }
       if (defined($lonhost)) {
           my $cachetime = 24*3600;
           my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost);
           if (defined($cached)) {
               return $loncaparev;
           } else {
               my $loncaparev = &reply('serverloncaparev',$lonhost);
               return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime);
           }
       }
   }
   
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
 sub subreply {  sub subreply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
Line 528  sub appenv { Line 554  sub appenv {
 # ----------------------------------------------------- Delete from Environment  # ----------------------------------------------------- Delete from Environment
   
 sub delenv {  sub delenv {
     my $delthis=shift;      my ($delthis,$regexp) = @_;
     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {      if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
         &logthis("<font color=\"blue\">WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
                 "Attempt to delete from environment ".$delthis);                  "Attempt to delete from environment ".$delthis);
Line 541  sub delenv { Line 567  sub delenv {
  tie(my %disk_env,'GDBM_File',$env{'user.environment'},   tie(my %disk_env,'GDBM_File',$env{'user.environment'},
     (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {      (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
  foreach my $key (keys(%disk_env)) {   foreach my $key (keys(%disk_env)) {
     if ($key=~/^\Q$delthis\E/) {       if ($regexp) {
  delete($env{$key});                  if ($key=~/^$delthis/) {
  delete($disk_env{$key});                      delete($env{$key});
     }                      delete($disk_env{$key});
                   } 
               } else {
                   if ($key=~/^\Q$delthis\E/) {
       delete($env{$key});
       delete($disk_env{$key});
           }
               }
  }   }
  untie(%disk_env);   untie(%disk_env);
     }      }
Line 686  sub spareserver { Line 719  sub spareserver {
         if ($protocol{$spare_server} eq 'https') {          if ($protocol{$spare_server} eq 'https') {
             $protocol = $protocol{$spare_server};              $protocol = $protocol{$spare_server};
         }          }
  $spare_server = $protocol.'://'.&hostname($spare_server);          if (defined($spare_server)) {
               my $hostname = &hostname($spare_server);
               if (defined($hostname)) {  
           $spare_server = $protocol.'://'.$hostname;
               }
           }
     }      }
     return $spare_server;      return $spare_server;
 }  }
Line 747  sub changepass { Line 785  sub changepass {
     my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;      my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
     $currentpass = &escape($currentpass);      $currentpass = &escape($currentpass);
     $newpass     = &escape($newpass);      $newpass     = &escape($newpass);
     my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context",      my $lonhost = $perlvar{'lonHostID'};
       my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context:$lonhost",
        $server);         $server);
     if (! $answer) {      if (! $answer) {
  &logthis("No reply on password change request to $server ".   &logthis("No reply on password change request to $server ".
Line 772  sub changepass { Line 811  sub changepass {
     } elsif ($answer =~ "^refused") {      } elsif ($answer =~ "^refused") {
  &logthis("$server refused to change $uname in $udom password because ".   &logthis("$server refused to change $uname in $udom password because ".
  "it was sent an unencrypted request to change the password.");   "it was sent an unencrypted request to change the password.");
       } elsif ($answer =~ "invalid_client") {
           &logthis("$server refused to change $uname in $udom password because ".
                    "it was a reset by e-mail originating from an invalid server.");
     }      }
     return $answer;      return $answer;
 }  }
Line 921  sub idput { Line 963  sub idput {
     }      }
 }  }
   
 # ------------------------------------------- get items from domain db files     # ------------------------------dump from db file owned by domainconfig user
   sub dump_dom {
       my ($namespace,$udom,$regexp,$range)=@_;
       if (!$udom) {
           $udom=$env{'user.domain'};
       }
       my %returnhash;
       if ($udom) {
           my $uname = &get_domainconfiguser($udom);
           %returnhash = &dump($namespace,$udom,$uname,$regexp,$range);
       }
       return %returnhash;
   }
   
   # ------------------------------------------ get items from domain db files   
   
 sub get_dom {  sub get_dom {
     my ($namespace,$storearr,$udom,$uhome)=@_;      my ($namespace,$storearr,$udom,$uhome)=@_;
Line 995  sub put_dom { Line 1051  sub put_dom {
     }      }
 }  }
   
   # --------------------- newput for items in db file owned by domainconfig user
   sub newput_dom {
       my ($namespace,$storehash,$udom) = @_;
       my $result;
       if (!$udom) {
           $udom=$env{'user.domain'};
       }
       if ($udom) {
           my $uname = &get_domainconfiguser($udom);
           $result = &newput($namespace,$storehash,$udom,$uname);
       }
       return $result;
   }
   
   # --------------------- delete for items in db file owned by domainconfig user
   sub del_dom {
       my ($namespace,$storearr,$udom)=@_;
       if (ref($storearr) eq 'ARRAY') {
           if (!$udom) {
               $udom=$env{'user.domain'};
           }
           if ($udom) {
               my $uname = &get_domainconfiguser($udom); 
               return &del($namespace,$storearr,$udom,$uname);
           }
       }
   }
   
   # ----------------------------------construct domainconfig user for a domain 
   sub get_domainconfiguser {
       my ($udom) = @_;
       return $udom.'-domainconfig';
   }
   
 sub retrieve_inst_usertypes {  sub retrieve_inst_usertypes {
     my ($udom) = @_;      my ($udom) = @_;
     my (%returnhash,@order);      my (%returnhash,@order);
     if (defined(&domain($udom,'primary'))) {      my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
         my $uhome=&domain($udom,'primary');      if ((ref($domdefs{'inststatustypes'}) eq 'HASH') && 
         my $rep=&reply("inst_usertypes:$udom",$uhome);          (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
         if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {          %returnhash = %{$domdefs{'inststatustypes'}};
             &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");          @order = @{$domdefs{'inststatusorder'}};
             return (\%returnhash,\@order);  
         }  
         my ($hashitems,$orderitems) = split(/:/,$rep);   
         my @pairs=split(/\&/,$hashitems);  
         foreach my $item (@pairs) {  
             my ($key,$value)=split(/=/,$item,2);  
             $key = &unescape($key);  
             next if ($key =~ /^error: 2 /);  
             $returnhash{$key}=&thaw_unescape($value);  
         }  
         my @esc_order = split(/\&/,$orderitems);  
         foreach my $item (@esc_order) {  
             push(@order,&unescape($item));  
         }  
     } else {      } else {
         &logthis("get_dom failed - no primary domain server for $udom");          if (defined(&domain($udom,'primary'))) {
               my $uhome=&domain($udom,'primary');
               my $rep=&reply("inst_usertypes:$udom",$uhome);
               if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
                   &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");
                   return (\%returnhash,\@order);
               }
               my ($hashitems,$orderitems) = split(/:/,$rep); 
               my @pairs=split(/\&/,$hashitems);
               foreach my $item (@pairs) {
                   my ($key,$value)=split(/=/,$item,2);
                   $key = &unescape($key);
                   next if ($key =~ /^error: 2 /);
                   $returnhash{$key}=&thaw_unescape($value);
               }
               my @esc_order = split(/\&/,$orderitems);
               foreach my $item (@esc_order) {
                   push(@order,&unescape($item));
               }
           } else {
               &logthis("get_dom failed - no primary domain server for $udom");
           }
     }      }
     return (\%returnhash,\@order);      return (\%returnhash,\@order);
 }  }
Line 1255  sub get_domain_defaults { Line 1352  sub get_domain_defaults {
     }      }
     my %domdefaults;      my %domdefaults;
     my %domconfig =      my %domconfig =
          &Apache::lonnet::get_dom('configuration',['defaults','quotas'],$domain);           &Apache::lonnet::get_dom('configuration',['defaults','quotas',
                                     'requestcourses','inststatus',
                                     'coursedefaults'],$domain);
     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'}; 
         $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};          $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
Line 1281  sub get_domain_defaults { Line 1380  sub get_domain_defaults {
         }          }
     }      }
     if (ref($domconfig{'requestcourses'}) eq 'HASH') {      if (ref($domconfig{'requestcourses'}) eq 'HASH') {
         foreach my $item ('official','unofficial') {          foreach my $item ('official','unofficial','community') {
             $domdefaults{$item} = $domconfig{'requestcourses'}{$item};              $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
         }          }
     }      }
       if (ref($domconfig{'inststatus'}) eq 'HASH') {
           foreach my $item ('inststatustypes','inststatusorder') {
               $domdefaults{$item} = $domconfig{'inststatus'}{$item};
           }
       }
       if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
           foreach my $item ('canuse_pdfforms') {
               $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};
           }
       }
     &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,      &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
                                   $cachetime);                                    $cachetime);
     return %domdefaults;      return %domdefaults;
Line 1615  sub userenvironment { Line 1724  sub userenvironment {
     }      }
     $items=~s/\&$//;      $items=~s/\&$//;
     my %returnhash=();      my %returnhash=();
     my @answer=split(/\&/,      my $uhome = &homeserver($unam,$udom);
                 &reply('get:'.$udom.':'.$unam.':environment:'.$items,      unless ($uhome eq 'no_host') {
                       &homeserver($unam,$udom)));          my @answer=split(/\&/, 
     my $i;              &reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome));
     for ($i=0;$i<=$#what;$i++) {          if ($#answer==0 && $answer[0] =~ /^(con_lost|error:|no_such_host)/i) {
  $returnhash{$what[$i]}=&unescape($answer[$i]);              return %returnhash;
           }
           my $i;
           for ($i=0;$i<=$#what;$i++) {
       $returnhash{$what[$i]}=&unescape($answer[$i]);
           }
     }      }
     return %returnhash;      return %returnhash;
 }  }
Line 1816  sub ssi_body { Line 1930  sub ssi_body {
     if ($filelink=~/^https?\:/) {      if ($filelink=~/^https?\:/) {
        ($output,$response)=&externalssi($filelink);         ($output,$response)=&externalssi($filelink);
     } else {      } else {
          $filelink .= $filelink=~/\?/ ? '&' : '?';
          $filelink .= 'inhibitmenu=yes';
        ($output,$response)=&ssi($filelink,%form);         ($output,$response)=&ssi($filelink,%form);
     }      }
     $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;      $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
Line 1859  sub ssi { Line 1975  sub ssi {
     &Apache::lonenc::check_encrypt(\$fn);      &Apache::lonenc::check_encrypt(\$fn);
     if (%form) {      if (%form) {
       $request=new HTTP::Request('POST',&absolute_url().$fn);        $request=new HTTP::Request('POST',&absolute_url().$fn);
       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));        $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form)));
     } else {      } else {
       $request=new HTTP::Request('GET',&absolute_url().$fn);        $request=new HTTP::Request('GET',&absolute_url().$fn);
     }      }
Line 1957  sub process_coursefile { Line 2073  sub process_coursefile {
             print $fh $env{'form.'.$source};              print $fh $env{'form.'.$source};
             close($fh);              close($fh);
             if ($parser eq 'parse') {              if ($parser eq 'parse') {
                 my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);                  my $mm = new File::MMagic;
                 unless ($parse_result eq 'ok') {                  my $mime_type = $mm->checktype_filename($filepath.'/'.$fname);
                     &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);                  if ($mime_type eq 'text/html') {
                       my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);
                       unless ($parse_result eq 'ok') {
                           &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
                       }
                 }                  }
             }              }
             $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,              $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
Line 2121  sub userfileupload { Line 2241  sub userfileupload {
         close($fh);          close($fh);
         return $fullpath.'/'.$fname;          return $fullpath.'/'.$fname;
     }      }
           if ($subdir eq 'scantron') {
           $fname = 'scantron_orig_'.$fname;
       } else {   
 # Create the directory if not present  # Create the directory if not present
     $fname="$subdir/$fname";          $fname="$subdir/$fname";
       }
     if ($coursedoc) {      if ($coursedoc) {
  my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};   my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
  my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};   my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
Line 2198  sub finishuserfileupload { Line 2321  sub finishuserfileupload {
  }   }
     }      }
     if ($parser eq 'parse') {      if ($parser eq 'parse') {
         my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles,          my $mm = new File::MMagic;
    $codebase);          my $mime_type = $mm->checktype_filename($filepath.'/'.$file);
         unless ($parse_result eq 'ok') {          if ($mime_type eq 'text/html') {
             &logthis('Failed to parse '.$filepath.$file.              my $parse_result = &extract_embedded_items($filepath.'/'.$file,
      ' for embedded media: '.$parse_result);                                                          $allfiles,$codebase);
               unless ($parse_result eq 'ok') {
                   &logthis('Failed to parse '.$filepath.$file.
              ' for embedded media: '.$parse_result); 
               }
         }          }
     }      }
     if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {      if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
Line 2506  sub flushcourselogs { Line 2633  sub flushcourselogs {
 # Reverse lookup of domain roles (dc, ad, li, sc, au)  # Reverse lookup of domain roles (dc, ad, li, sc, au)
 #  #
     my %domrolebuffer = ();      my %domrolebuffer = ();
     foreach my $entry (keys %domainrolehash) {      foreach my $entry (keys(%domainrolehash)) {
         my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry);          my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry);
         if ($domrolebuffer{$rudom}) {          if ($domrolebuffer{$rudom}) {
             $domrolebuffer{$rudom}.='&'.&escape($entry).              $domrolebuffer{$rudom}.='&'.&escape($entry).
Line 2611  sub userrolelog { Line 2738  sub userrolelog {
     if (($trole=~/^ca/) || ($trole=~/^aa/) ||      if (($trole=~/^ca/) || ($trole=~/^aa/) ||
         ($trole=~/^in/) || ($trole=~/^cc/) ||          ($trole=~/^in/) || ($trole=~/^cc/) ||
         ($trole=~/^ep/) || ($trole=~/^cr/) ||          ($trole=~/^ep/) || ($trole=~/^cr/) ||
         ($trole=~/^ta/)) {          ($trole=~/^ta/) || ($trole=~/^co/)) {
        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);         my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
        $userrolehash         $userrolehash
          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
Line 2620  sub userrolelog { Line 2747  sub userrolelog {
     if (($env{'request.role'} =~ /dc\./) &&      if (($env{'request.role'} =~ /dc\./) &&
  (($trole=~/^au/) || ($trole=~/^in/) ||   (($trole=~/^au/) || ($trole=~/^in/) ||
  ($trole=~/^cc/) || ($trole=~/^ep/) ||   ($trole=~/^cc/) || ($trole=~/^ep/) ||
  ($trole=~/^cr/) || ($trole=~/^ta/))) {   ($trole=~/^cr/) || ($trole=~/^ta/) ||
            ($trole=~/^co/))) {
        $userrolehash         $userrolehash
          {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}           {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
                     =$tend.':'.$tstart;                      =$tend.':'.$tstart;
Line 2641  sub courserolelog { Line 2769  sub courserolelog {
     if (($trole eq 'cc') || ($trole eq 'in') ||      if (($trole eq 'cc') || ($trole eq 'in') ||
         ($trole eq 'ep') || ($trole eq 'ad') ||          ($trole eq 'ep') || ($trole eq 'ad') ||
         ($trole eq 'ta') || ($trole eq 'st') ||          ($trole eq 'ta') || ($trole eq 'st') ||
         ($trole=~/^cr/) || ($trole eq 'gr')) {          ($trole=~/^cr/) || ($trole eq 'gr') ||
           ($trole eq 'co')) {
         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 2661  sub courserolelog { Line 2790  sub courserolelog {
                 $storehash{'section'} = $sec;                  $storehash{'section'} = $sec;
             }              }
             &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);              &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);
               if (($trole ne 'st') || ($sec ne '')) {
                   &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);
               }
         }          }
     }      }
     return;      return;
Line 2670  sub get_course_adv_roles { Line 2802  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));
     my %coursehash=&coursedescription($cid);      my %coursehash=&coursedescription($cid);
       my $crstype = &Apache::loncommon::course_type($cid);
     my %nothide=();      my %nothide=();
     foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {      foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
         if ($user !~ /:/) {          if ($user !~ /:/) {
Line 2682  sub get_course_adv_roles { Line 2815  sub get_course_adv_roles {
     my %dumphash=      my %dumphash=
             &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});              &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
     my $now=time;      my $now=time;
     foreach my $entry (keys %dumphash) {      my %privileged;
       foreach my $entry (keys(%dumphash)) {
  my ($tend,$tstart)=split(/\:/,$dumphash{$entry});   my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
         if (($tstart) && ($tstart<0)) { next; }          if (($tstart) && ($tstart<0)) { next; }
         if (($tend) && ($tend<$now)) { next; }          if (($tend) && ($tend<$now)) { next; }
         if (($tstart) && ($now<$tstart)) { next; }          if (($tstart) && ($now<$tstart)) { next; }
         my ($role,$username,$domain,$section)=split(/\:/,$entry);          my ($role,$username,$domain,$section)=split(/\:/,$entry);
  if ($username eq '' || $domain eq '') { next; }   if ($username eq '' || $domain eq '') { next; }
  if ((&privileged($username,$domain)) &&           unless (ref($privileged{$domain}) eq 'HASH') {
     (!$nothide{$username.':'.$domain})) { next; }              my %dompersonnel =
                   &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
               $privileged{$domain} = {};
               foreach my $server (keys(%dompersonnel)) {
                   if (ref($dompersonnel{$server}) eq 'HASH') {
                       foreach my $user (keys(%{$dompersonnel{$server}})) {
                           my ($trole,$uname,$udom) = split(/:/,$user);
                           $privileged{$udom}{$uname} = 1;
                       }
                   }
               }
           }
           if ((exists($privileged{$domain}{$username})) && 
               (!$nothide{$username.':'.$domain})) { next; }
  if ($role eq 'cr') { next; }   if ($role eq 'cr') { next; }
         if ($codes) {          if ($codes) {
             if ($section) { $role .= ':'.$section; }              if ($section) { $role .= ':'.$section; }
Line 2700  sub get_course_adv_roles { Line 2847  sub get_course_adv_roles {
                 $returnhash{$role}=$username.':'.$domain;                  $returnhash{$role}=$username.':'.$domain;
             }              }
         } else {          } else {
             my $key=&plaintext($role);              my $key=&plaintext($role,$crstype);
             if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; }              if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; }
             if ($returnhash{$key}) {              if ($returnhash{$key}) {
         $returnhash{$key}.=','.$username.':'.$domain;          $returnhash{$key}.=','.$username.':'.$domain;
Line 2735  sub get_my_roles { Line 2882  sub get_my_roles {
     }      }
     my %returnhash=();      my %returnhash=();
     my $now=time;      my $now=time;
       my %privileged;
     foreach my $entry (keys(%dumphash)) {      foreach my $entry (keys(%dumphash)) {
         my ($role,$tend,$tstart);          my ($role,$tend,$tstart);
         if ($context eq 'userroles') {          if ($context eq 'userroles') {
Line 2783  sub get_my_roles { Line 2931  sub get_my_roles {
             }              }
         }          }
         if ($hidepriv) {          if ($hidepriv) {
             if ((&privileged($username,$domain)) &&              if ($context eq 'userroles') {
                 (!$nothide{$username.':'.$domain})) {                   if ((&privileged($username,$domain)) &&
                 next;                      (!$nothide{$username.':'.$domain})) {
                       next;
                   }
               } else {
                   unless (ref($privileged{$domain}) eq 'HASH') {
                       my %dompersonnel =
                           &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
                       $privileged{$domain} = {};
                       if (keys(%dompersonnel)) {
                           foreach my $server (keys(%dompersonnel)) {
                               if (ref($dompersonnel{$server}) eq 'HASH') {
                                   foreach my $user (keys(%{$dompersonnel{$server}})) {
                                       my ($trole,$uname,$udom) = split(/:/,$user);
                                       $privileged{$udom}{$uname} = $trole;
                                   }
                               }
                           }
                       }
                   }
                   if (exists($privileged{$domain}{$username})) {
                       if (!$nothide{$username.':'.$domain}) {
                           next;
                       }
                   }
             }              }
         }          }
         if ($withsec) {          if ($withsec) {
Line 2871  sub courseidput { Line 3042  sub courseidput {
 sub courseiddump {  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
         $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,          $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
         $selfenrollonly,$catfilter,$showhidden,$caller)=@_;          $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
           $cloneonly,$createdbefore,$createdafter,$creationcontext)=@_;
     my $as_hash = 1;      my $as_hash = 1;
     my %returnhash;      my %returnhash;
     if (!$domfilter) { $domfilter=''; }      if (!$domfilter) { $domfilter=''; }
Line 2890  sub courseiddump { Line 3062  sub courseiddump {
                          ':'.&escape($coursefilter).':'.&escape($typefilter).                           ':'.&escape($coursefilter).':'.&escape($typefilter).
                          ':'.&escape($regexp_ok).':'.$as_hash.':'.                           ':'.&escape($regexp_ok).':'.$as_hash.':'.
                          &escape($selfenrollonly).':'.&escape($catfilter).':'.                           &escape($selfenrollonly).':'.&escape($catfilter).':'.
                          $showhidden.':'.$caller,$tryserver);                           $showhidden.':'.$caller.':'.&escape($cloner).':'.
                            &escape($cc_clone).':'.$cloneonly.':'.
                            &escape($createdbefore).':'.&escape($createdafter).':'.
                            &escape($creationcontext),$tryserver);
                 my @pairs=split(/\&/,$rep);                  my @pairs=split(/\&/,$rep);
                 foreach my $item (@pairs) {                  foreach my $item (@pairs) {
                     my ($key,$value)=split(/\=/,$item,2);                      my ($key,$value)=split(/\=/,$item,2);
Line 2905  sub courseiddump { Line 3080  sub courseiddump {
                         for (my $i=0; $i<@responses; $i++) {                          for (my $i=0; $i<@responses; $i++) {
                             $returnhash{$key}{$items[$i]} = &unescape($responses[$i]);                              $returnhash{$key}{$items[$i]} = &unescape($responses[$i]);
                         }                          }
                     }                       }
                 }                  }
             }              }
         }          }
Line 2945  sub dcmaildump { Line 3120  sub dcmaildump {
   
 sub get_domain_roles {  sub get_domain_roles {
     my ($dom,$roles,$startdate,$enddate)=@_;      my ($dom,$roles,$startdate,$enddate)=@_;
     if (undef($startdate) || $startdate eq '') {      if ((!defined($startdate)) || ($startdate eq '')) {
         $startdate = '.';          $startdate = '.';
     }      }
     if (undef($enddate) || $enddate eq '') {      if ((!defined($enddate)) || ($enddate eq '')) {
         $enddate = '.';          $enddate = '.';
     }      }
     my $rolelist;      my $rolelist;
Line 3355  sub tmpreset { Line 3530  sub tmpreset {
   if (tie(%hash,'GDBM_File',    if (tie(%hash,'GDBM_File',
   $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',    $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
   &GDBM_WRCREAT(),0640)) {    &GDBM_WRCREAT(),0640)) {
     foreach my $key (keys %hash) {      foreach my $key (keys(%hash)) {
       if ($key=~ /:$symb/) {        if ($key=~ /:$symb/) {
  delete($hash{$key});   delete($hash{$key});
       }        }
Line 3638  sub privileged { Line 3813  sub privileged {
     my ($username,$domain)=@_;      my ($username,$domain)=@_;
     my $rolesdump=&reply("dump:$domain:$username:roles",      my $rolesdump=&reply("dump:$domain:$username:roles",
  &homeserver($username,$domain));   &homeserver($username,$domain));
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; }      if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || 
           ($rolesdump =~ /^error:/)) {
           return 0;
       }
     my $now=time;      my $now=time;
     if ($rolesdump ne '') {      if ($rolesdump ne '') {
         foreach my $entry (split(/&/,$rolesdump)) {          foreach my $entry (split(/&/,$rolesdump)) {
Line 3666  sub privileged { Line 3844  sub privileged {
   
 sub rolesinit {  sub rolesinit {
     my ($domain,$username,$authhost)=@_;      my ($domain,$username,$authhost)=@_;
     my %userroles;      my $now=time;
       my %userroles = ('user.login.time' => $now);
     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);      my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return \%userroles; }      if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || 
           ($rolesdump =~ /^error:/)) { 
           return \%userroles;
       }
     my %allroles=();      my %allroles=();
     my %allgroups=();         my %allgroups=();   
     my $now=time;  
     %userroles = ('user.login.time' => $now);  
     my $group_privs;      my $group_privs;
   
     if ($rolesdump ne '') {      if ($rolesdump ne '') {
Line 3738  sub custom_roleprivs { Line 3918  sub custom_roleprivs {
         if (($rdummy ne 'con_lost') && ($roledef ne '')) {          if (($rdummy ne 'con_lost') && ($roledef ne '')) {
             my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef);              my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef);
             if (defined($syspriv)) {              if (defined($syspriv)) {
                   if ($trest =~ /^$match_community$/) {
                       $syspriv =~ s/bre\&S//; 
                   }
                 $$allroles{'cm./'}.=':'.$syspriv;                  $$allroles{'cm./'}.=':'.$syspriv;
                 $$allroles{$spec.'./'}.=':'.$syspriv;                  $$allroles{$spec.'./'}.=':'.$syspriv;
             }              }
Line 3791  sub set_userprivs { Line 3974  sub set_userprivs {
     my $adv=0;      my $adv=0;
     my %grouproles = ();      my %grouproles = ();
     if (keys(%{$allgroups}) > 0) {      if (keys(%{$allgroups}) > 0) {
         foreach my $role (keys %{$allroles}) {          foreach my $role (keys(%{$allroles})) {
             my ($trole,$area,$sec,$extendedarea);              my ($trole,$area,$sec,$extendedarea);
             if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {              if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {
                 $trole = $1;                  $trole = $1;
Line 3834  sub set_userprivs { Line 4017  sub set_userprivs {
     return ($author,$adv);      return ($author,$adv);
 }  }
   
   sub role_status {
       my ($rolekey,$then,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
       my @pwhere = ();
       if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
           (undef,undef,$$role,@pwhere)=split(/\./,$rolekey);
           unless (!defined($$role) || $$role eq '') {
               $$where=join('.',@pwhere);
               $$trolecode=$$role.'.'.$$where;
               ($$tstart,$$tend)=split(/\./,$env{$rolekey});
               $$tstatus='is';
               if ($$tstart && $$tstart>$then) {
                   $$tstatus='future';
                   if ($$tstart<$now) {
                       if ($$tstart && $$tstart>$refresh) {
                           if (($$where ne '') && ($$role ne '')) {
                               my (%allroles,%allgroups,$group_privs);
                               my %userroles = (
                                   'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend
                               );
                               my $spec=$$role.'.'.$$where;
                               my ($tdummy,$tdomain,$trest)=split(/\//,$$where);
                               if ($$role eq 'gr') {
                                   my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},
                                                       $env{'user.name'})=@_;
                                   my ($trole) = split('_',$role,1);
                                   (undef,my $group_privs) = split(/\//,$trole);
                                   $group_privs = &unescape($group_privs);
                               }
                               if ($$role =~ /^cr\//) {
                                   &custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where);
                               } elsif ($$role eq 'gr') {
                                   my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},
                                                       $env{'user.name'});
                                   my $trole = split('_',$rolehash{$$where.'_'.$$role},1);
                                   (undef,my $group_privs) = split(/\//,$trole);
                                   $group_privs = &unescape($group_privs);
                                   &group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);
                               } else {
                                   &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
                               }
                               my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups);
                               &appenv(\%userroles,[$$role,'cm']);
                               &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
                           }
                       }
                       $$tstatus = 'is';
                   }
               }
               if ($$tend) {
                   if ($$tend<$then) {
                       $$tstatus='expired';
                   } elsif ($$tend<$now) {
                       $$tstatus='will_not';
                   }
               }
           }
       }
   }
   
   sub check_adhoc_privs {
       my ($cdom,$cnum,$then,$refresh,$now,$checkrole) = @_;
       my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
       if ($env{$cckey}) {
           my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
           &role_status($cckey,$then,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
           unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {
               &set_adhoc_privileges($cdom,$cnum,$checkrole);
           }
       } else {
           &set_adhoc_privileges($cdom,$cnum,$checkrole);
       }
   }
   
   sub set_adhoc_privileges {
   # role can be cc or ca
       my ($dcdom,$pickedcourse,$role) = @_;
       my $area = '/'.$dcdom.'/'.$pickedcourse;
       my $spec = $role.'.'.$area;
       my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
                                     $env{'user.name'});
       my %ccrole = ();
       &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);
       my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);
       &appenv(\%userroles,[$role,'cm']);
       &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
       &appenv( {'request.role'        => $spec,
                 'request.role.domain' => $dcdom,
                 'request.course.sec'  => ''
                }
              );
       my $tadv=0;
       if (&allowed('adv') eq 'F') { $tadv=1; }
       &appenv({'request.role.adv'    => $tadv});
   }
   
 # --------------------------------------------------------------- get interface  # --------------------------------------------------------------- get interface
   
 sub get {  sub get {
Line 4443  sub usertools_access { Line 4721  sub usertools_access {
         %tools = (          %tools = (
                       official   => 1,                        official   => 1,
                       unofficial => 1,                        unofficial => 1,
                         community  => 1,
                  );                   );
     } else {      } else {
         %tools = (          %tools = (
Line 4475  sub usertools_access { Line 4754  sub usertools_access {
         $toolstatus = $env{'environment.'.$context.'.'.$tool};          $toolstatus = $env{'environment.'.$context.'.'.$tool};
         $inststatus = $env{'environment.inststatus'};          $inststatus = $env{'environment.inststatus'};
     } else {      } else {
         my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool);          my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');
         $toolstatus = $userenv{$context.'.'.$tool};          $toolstatus = $userenv{$context.'.'.$tool};
         $inststatus = $userenv{'inststatus'};          $inststatus = $userenv{'inststatus'};
     }      }
Line 4576  sub is_advanced_user { Line 4855  sub is_advanced_user {
     return $is_adv;      return $is_adv;
 }  }
   
   sub check_can_request {
       my ($dom,$can_request,$request_domains) = @_;
       my $canreq = 0;
       my ($types,$typename) = &Apache::loncommon::course_types();
       my @options = ('approval','validate','autolimit');
       my $optregex = join('|',@options);
       if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
           foreach my $type (@{$types}) {
               if (&usertools_access($env{'user.name'},
                                     $env{'user.domain'},
                                     $type,undef,'requestcourses')) {
                   $canreq ++;
                   if (ref($request_domains) eq 'HASH') {
                       push(@{$request_domains->{$type}},$env{'user.domain'});
                   }
                   if ($dom eq $env{'user.domain'}) {
                       $can_request->{$type} = 1;
                   }
               }
               if ($env{'environment.reqcrsotherdom.'.$type} ne '') {
                   my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});
                   if (@curr > 0) {
                       foreach my $item (@curr) {
                           if (ref($request_domains) eq 'HASH') {
                               my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);
                               if ($otherdom ne '') {
                                   if (ref($request_domains->{$type}) eq 'ARRAY') {
                                       unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {
                                           push(@{$request_domains->{$type}},$otherdom);
                                       }
                                   } else {
                                       push(@{$request_domains->{$type}},$otherdom);
                                   }
                               }
                           }
                       }
                       unless($dom eq $env{'user.domain'}) {
                           $canreq ++;
                           if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {
                               $can_request->{$type} = 1;
                           }
                       }
                   }
               }
           }
       }
       return $canreq;
   }
   
 # ---------------------------------------------- Custom access rule evaluation  # ---------------------------------------------- Custom access rule evaluation
   
 sub customaccess {  sub customaccess {
Line 4730  sub allowed { Line 5058  sub allowed {
     my $statecond=0;      my $statecond=0;
     my $courseprivid='';      my $courseprivid='';
   
       my $ownaccess;
       # Community Coordinator or Assistant Co-author browsing resource space.
       if (($priv eq 'bro') && ($env{'user.author'})) {
           if ($uri eq '') {
               $ownaccess = 1;
           } else {
               if (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) {
                   my $udom = $env{'user.domain'};
                   my $uname = $env{'user.name'};
                   if ($uri =~ m{^\Q$udom\E/?$}) {
                       $ownaccess = 1;
                   } elsif ($uri =~ m{^\Q$udom\E/\Q$uname\E/?}) {
                       unless ($uri =~ m{\.\./}) {
                           $ownaccess = 1;
                       }
                   } elsif (($udom ne 'public') && ($uname ne 'public')) {
                       my $now = time;
                       if ($uri =~ m{^([^/]+)/?$}) {
                           my $adom = $1;
                           foreach my $key (keys(%env)) {
                               if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) {
                                   my ($start,$end) = split('.',$env{$key});
                                   if (($now >= $start) && (!$end || $end < $now)) {
                                       $ownaccess = 1;
                                       last;
                                   }
                               }
                           }
                       } elsif ($uri =~ m{^([^/]+)/([^/]+)/?}) {
                           my $adom = $1;
                           my $aname = $2;
                           foreach my $role ('ca','aa') { 
                               if ($env{"user.role.$role./$adom/$aname"}) {
                                   my ($start,$end) =
                                       split('.',$env{"user.role.$role./$adom/$aname"});
                                   if (($now >= $start) && (!$end || $end < $now)) {
                                       $ownaccess = 1;
                                       last;
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
   
 # Course  # Course
   
     if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {      if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {
        $thisallowed.=$1;          unless (($priv eq 'bro') && (!$ownaccess)) {
               $thisallowed.=$1;
           }
     }      }
   
 # Domain  # Domain
   
     if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}      if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
        =~/\Q$priv\E\&([^\:]*)/) {         =~/\Q$priv\E\&([^\:]*)/) {
        $thisallowed.=$1;          unless (($priv eq 'bro') && (!$ownaccess)) {
               $thisallowed.=$1;
           }
     }      }
   
 # Course: uri itself is a course  # Course: uri itself is a course
Line 4750  sub allowed { Line 5129  sub allowed {
   
     if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}      if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}
        =~/\Q$priv\E\&([^\:]*)/) {         =~/\Q$priv\E\&([^\:]*)/) {
        $thisallowed.=$1;          unless (($priv eq 'bro') && (!$ownaccess)) {
               $thisallowed.=$1;
           }
     }      }
   
 # URI is an uploaded document for this course, default permissions don't matter  # URI is an uploaded document for this course, default permissions don't matter
Line 4890  sub allowed { Line 5271  sub allowed {
   
     my $envkey;      my $envkey;
     if ($thisallowed=~/L/) {      if ($thisallowed=~/L/) {
         foreach $envkey (keys %env) {          foreach $envkey (keys(%env)) {
            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {             if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                my $courseid=$2;                 my $courseid=$2;
                my $roleid=$1.'.'.$2;                 my $roleid=$1.'.'.$2;
Line 5181  sub fetch_enrollment_query { Line 5562  sub fetch_enrollment_query {
     }      }
     my $host=&hostname($homeserver);      my $host=&hostname($homeserver);
     my $cmd = '';      my $cmd = '';
     foreach my $affiliate (keys %{$affiliatesref}) {      foreach my $affiliate (keys(%{$affiliatesref})) {
         $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';          $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
     }      }
     $cmd =~ s/%%$//;      $cmd =~ s/%%$//;
Line 5314  sub auto_run { Line 5695  sub auto_run {
   
 sub auto_get_sections {  sub auto_get_sections {
     my ($cnum,$cdom,$inst_coursecode) = @_;      my ($cnum,$cdom,$inst_coursecode) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver;
     my @secs = ();      if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { 
     my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));          $homeserver = &homeserver($cnum,$cdom);
     unless ($response eq 'refused') {      }
         @secs = split(/:/,$response);      if (!defined($homeserver)) { 
           if ($cdom =~ /^$match_domain$/) {
               $homeserver = &domain($cdom,'primary');
           }
       }
       my @secs;
       if (defined($homeserver)) {
           my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
           unless ($response eq 'refused') {
               @secs = split(/:/,$response);
           }
     }      }
     return @secs;      return @secs;
 }  }
Line 5337  sub auto_validate_courseID { Line 5728  sub auto_validate_courseID {
     return $response;      return $response;
 }  }
   
   sub auto_validate_instcode {
       my ($cnum,$cdom,$instcode,$owner) = @_;
       my ($homeserver,$response);
       if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
           $homeserver = &homeserver($cnum,$cdom);
       }
       if (!defined($homeserver)) {
           if ($cdom =~ /^$match_domain$/) {
               $homeserver = &domain($cdom,'primary');
           }
       }
       my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
                              &escape($instcode).':'.&escape($owner),$homeserver));
       my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);
       return ($outcome,$description);
   }
   
 sub auto_create_password {  sub auto_create_password {
     my ($cnum,$cdom,$authparam,$udom) = @_;      my ($cnum,$cdom,$authparam,$udom) = @_;
     my ($homeserver,$response);      my ($homeserver,$response);
Line 5451  sub auto_instcode_format { Line 5859  sub auto_instcode_format {
  push(@homeservers,$tryserver);   push(@homeservers,$tryserver);
     }      }
         }          }
       } elsif ($caller eq 'requests') {
           if ($codedom =~ /^$match_domain$/) {
               my $chome = &domain($codedom,'primary');
               unless ($chome eq 'no_host') {
                   push(@homeservers,$chome);
               }
           }
     } else {      } else {
         push(@homeservers,&homeserver($caller,$codedom));          push(@homeservers,&homeserver($caller,$codedom));
     }      }
Line 5508  sub auto_instcode_defaults { Line 5923  sub auto_instcode_defaults {
     }      }
   
     return $response;      return $response;
 }   }
   
   sub auto_possible_instcodes {
       my ($domain,$codetitles,$cat_titles,$cat_orders,$code_order) = @_;
       unless ((ref($codetitles) eq 'ARRAY') && (ref($cat_titles) eq 'HASH') && 
               (ref($cat_orders) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {
           return;
       }
       my (@homeservers,$uhome);
       if (defined(&domain($domain,'primary'))) {
           $uhome=&domain($domain,'primary');
           push(@homeservers,&domain($domain,'primary'));
       } else {
           my %servers = &get_servers($domain,'library');
           foreach my $tryserver (keys(%servers)) {
               if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
                   push(@homeservers,$tryserver);
               }
           }
       }
       my $response;
       foreach my $server (@homeservers) {
           $response=&reply('autopossibleinstcodes:'.$domain,$server);
           next if ($response =~ /(con_lost|error|no_such_host|refused)/);
           my ($codetitlestr,$codeorderstr,$cat_title,$cat_order) = 
               split(':',$response);
           @{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr));
           @{$code_order} = map { &unescape($_); } (split('&',$codeorderstr));
           foreach my $item (split('&',$cat_title)) {   
               my ($name,$value)=split('=',$item);
               $cat_titles->{&unescape($name)}=&thaw_unescape($value);
           }
           foreach my $item (split('&',$cat_order)) {
               my ($name,$value)=split('=',$item);
               $cat_orders->{&unescape($name)}=&thaw_unescape($value);
           }
           return 'ok';
       }
       return $response;
   }
   
   sub auto_courserequest_checks {
       my ($dom) = @_;
       my ($homeserver,%validations);
       if ($dom =~ /^$match_domain$/) {
           $homeserver = &domain($dom,'primary');
       }
       unless ($homeserver eq 'no_host') {
           my $response=&reply('autocrsreqchecks:'.$dom,$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_courserequest_validation {
       my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_;
       my ($homeserver,$response);
       if ($dom =~ /^$match_domain$/) {
           $homeserver = &domain($dom,'primary');
       }
       unless ($homeserver eq 'no_host') {  
             
           $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).
                                       ':'.&escape($crstype).':'.&escape($inststatuslist).
                                       ':'.&escape($instcode).':'.&escape($instseclist),
                                       $homeserver));
       }
       return $response;
   }
   
 sub auto_validate_class_sec {  sub auto_validate_class_sec {
     my ($cdom,$cnum,$owners,$inst_class) = @_;      my ($cdom,$cnum,$owners,$inst_class) = @_;
Line 5661  sub devalidate_getgroups_cache { Line 6150  sub devalidate_getgroups_cache {
 # ------------------------------------------------------------------ Plain Text  # ------------------------------------------------------------------ Plain Text
   
 sub plaintext {  sub plaintext {
     my ($short,$type,$cid) = @_;      my ($short,$type,$cid,$forcedefault) = @_;
     if ($short =~ /^cr/) {      if ($short =~ m{^cr/}) {
  return (split('/',$short))[-1];   return (split('/',$short))[-1];
     }      }
     if (!defined($cid)) {      if (!defined($cid)) {
         $cid = $env{'request.course.id'};          $cid = $env{'request.course.id'};
     }      }
     if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) {  
         return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short.  
                                           '.plaintext'});  
     }  
     my %rolenames = (      my %rolenames = (
                       Course => 'std',                        Course    => 'std',
                       Group => 'alt1',                        Community => 'alt1',
                     );                      );
     if (defined($type) &&       if ($cid ne '') {
          defined($rolenames{$type}) &&           if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') {
          defined($prp{$short}{$rolenames{$type}})) {              unless ($forcedefault) {
                   my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'}; 
                   &Apache::lonlocal::mt_escape(\$roletext);
                   return &Apache::lonlocal::mt($roletext);
               }
           }
       }
       if ((defined($type)) && (defined($rolenames{$type})) &&
           (defined($rolenames{$type})) && 
           (defined($prp{$short}{$rolenames{$type}}))) {
         return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});          return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});
     } else {      } elsif ($cid ne '') {
         return &Apache::lonlocal::mt($prp{$short}{'std'});          my $crstype = $env{'course.'.$cid.'.type'};
           if (($crstype ne '') && (defined($rolenames{$crstype})) &&
               (defined($prp{$short}{$rolenames{$crstype}}))) {
               return &Apache::lonlocal::mt($prp{$short}{$rolenames{$crstype}});
           }
     }      }
       return &Apache::lonlocal::mt($prp{$short}{'std'});
 }  }
   
 # ----------------------------------------------------------------- Assign Role  # ----------------------------------------------------------------- Assign Role
Line 5695  sub assignrole { Line 6194  sub assignrole {
         my $cwosec=$url;          my $cwosec=$url;
         $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;          $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
  unless (&allowed('ccr',$cwosec)) {   unless (&allowed('ccr',$cwosec)) {
            &logthis('Refused custom assignrole: '.             my $refused = 1;
              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.             if ($context eq 'requestcourses') {
     $env{'user.name'}.' at '.$env{'user.domain'});                 if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
            return 'refused';                      if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {
                          if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {
                              my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
                              my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
                              if ($crsenv{'internal.courseowner'} eq
                                  $env{'user.name'}.':'.$env{'user.domain'}) {
                                  $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\//) {
Line 5724  sub assignrole { Line 6240  sub assignrole {
                 $refused = 1;                  $refused = 1;
             }              }
             if ($refused) {              if ($refused) {
                 if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {                  my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
                   if (!$selfenroll && $context eq 'course') {
                       my %crsenv;
                       if ($role eq 'cc' || $role eq 'co') {
                           %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
                           if (($role eq 'cc') && ($cnum !~ /^$match_community$/)) {
                               if ($env{'request.role'} eq 'cc./'.$cdom.'/'.$cnum) {
                                   if ($crsenv{'internal.courseowner'} eq 
                                       $env{'user.name'}.':'.$env{'user.domain'}) {
                                       $refused = '';
                                   }
                               }
                           } elsif (($role eq 'co') && ($cnum =~ /^$match_community$/)) { 
                               if ($env{'request.role'} eq 'co./'.$cdom.'/'.$cnum) {
                                   if ($crsenv{'internal.courseowner'} eq 
                                       $env{'user.name'}.':'.$env{'user.domain'}) {
                                       $refused = '';
                                   }
                               }
                           }
                       }
                   } elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
                     $refused = '';                      $refused = '';
                 } else {                  } elsif ($context eq 'requestcourses') {
                       my @possroles = ('st','ta','ep','in','cc','co');
                       if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
                           my $wrongcc;
                           if ($cnum =~ /^$match_community$/) {
                               $wrongcc = 1 if ($role eq 'cc');
                           } else {
                               $wrongcc = 1 if ($role eq 'co');
                           }
                           unless ($wrongcc) {
                               my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
                               if ($crsenv{'internal.courseowner'} eq 
                                    $env{'user.name'}.':'.$env{'user.domain'}) {
                                   $refused = '';
                               }
                           }
                       }
                   }
                   if ($refused) {
                     &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.                      &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
                              ' '.$role.' '.$end.' '.$start.' by '.                               ' '.$role.' '.$end.' '.$start.' by '.
                $env{'user.name'}.' at '.$env{'user.domain'});                 $env{'user.name'}.' at '.$env{'user.domain'});
Line 5891  sub modifyuser { Line 6446  sub modifyuser {
        if ($email=~/\@/) { $names{'permanentemail'} = $email; }         if ($email=~/\@/) { $names{'permanentemail'} = $email; }
     }      }
     if ($uid) { $names{'id'}  = $uid; }      if ($uid) { $names{'id'}  = $uid; }
     if (defined($inststatus)) { $names{'inststatus'} = $inststatus; }       if (defined($inststatus)) {
           $names{'inststatus'} = '';
           my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom);
           if (ref($usertypes) eq 'HASH') {
               my @okstatuses; 
               foreach my $item (split(/:/,$inststatus)) {
                   if (defined($usertypes->{$item})) {
                       push(@okstatuses,$item);  
                   }
               }
               if (@okstatuses) {
                   $names{'inststatus'} = join(':', map { &escape($_); } @okstatuses);
               }
           }
       }
     my $reply = &put('environment', \%names, $udom,$uname);      my $reply = &put('environment', \%names, $udom,$uname);
     if ($reply ne 'ok') { return 'error: '.$reply; }      if ($reply ne 'ok') { return 'error: '.$reply; }
     my $sqlresult = &update_allusers_table($uname,$udom,\%names);      my $sqlresult = &update_allusers_table($uname,$udom,\%names);
Line 5913  sub modifyuser { Line 6482  sub modifyuser {
 sub modifystudent {  sub modifystudent {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,      my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
         $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,          $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
         $selfenroll,$context)=@_;          $selfenroll,$context,$inststatus)=@_;
     if (!$cid) {      if (!$cid) {
  unless ($cid=$env{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
     return 'not_in_class';      return 'not_in_class';
Line 5922  sub modifystudent { Line 6491  sub modifystudent {
 # --------------------------------------------------------------- Make the user  # --------------------------------------------------------------- Make the user
     my $reply=&modifyuser      my $reply=&modifyuser
  ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,   ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
          $desiredhome,$email);           $desiredhome,$email,$inststatus);
     unless ($reply eq 'ok') { return $reply; }      unless ($reply eq 'ok') { return $reply; }
     # This will cause &modify_student_enrollment to get the uid from the      # This will cause &modify_student_enrollment to get the uid from the
     # students environment      # students environment
Line 6036  sub writecoursepref { Line 6605  sub writecoursepref {
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,      my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
         $course_owner,$crstype)=@_;          $course_owner,$crstype,$cnum,$context,$category)=@_;
     $url=&declutter($url);      $url=&declutter($url);
     my $cid='';      my $cid='';
     unless (&allowed('ccc',$udom)) {      if ($context eq 'requestcourses') {
           my $can_create = 0;
           my ($ownername,$ownerdom) = split(':',$course_owner);
           if ($udom eq $ownerdom) {
               if (&usertools_access($ownername,$ownerdom,$category,undef,
                                     $context)) {
                   $can_create = 1;
               }
           } else {
               my %userenv = &userenvironment($ownerdom,$ownername,'reqcrsotherdom.'.
                                              $category);
               if ($userenv{'reqcrsotherdom.'.$category} ne '') {
                   my @curr = split(',',$userenv{'reqcrsotherdom.'.$category});
                   if (@curr > 0) {
                       my @options = qw(approval validate autolimit);
                       my $optregex = join('|',@options);
                       if (grep(/^\Q$udom\E:($optregex)(=?\d*)$/,@curr)) {
                           $can_create = 1;
                       }
                   }
               }
           }
           if ($can_create) {
               unless ($ownername eq $env{'user.name'} && $ownerdom eq $env{'user.domain'}) {
                   unless (&allowed('ccc',$udom)) {
                       return 'refused'; 
                   }
               }
           } else {
               return 'refused';
           }
       } elsif (!&allowed('ccc',$udom)) {
         return 'refused';          return 'refused';
     }      }
 # ------------------------------------------------------------------- Create ID  # --------------------------------------------------------------- Get Unique ID
    my $uname=int(1+rand(9)).      my $uname;
        ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].      if ($cnum =~ /^$match_courseid$/) {
        substr($$.time,0,5).unpack("H8",pack("I32",time)).          my $chome=&homeserver($cnum,$udom,'true');
        unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};          if (($chome eq '') || ($chome eq 'no_host')) {
 # ----------------------------------------------- Make sure that does not exist              $uname = $cnum;
    my $uhome=&homeserver($uname,$udom,'true');          } else {
    unless (($uhome eq '') || ($uhome eq 'no_host')) {              $uname = &generate_coursenum($udom,$crstype);
        $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).          }
         unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};      } else {
        $uhome=&homeserver($uname,$udom,'true');                 $uname = &generate_coursenum($udom,$crstype);
        unless (($uhome eq '') || ($uhome eq 'no_host')) {      }
            return 'error: unable to generate unique course-ID';      return $uname if ($uname =~ /^error/);
        }   # -------------------------------------------------- Check supplied server name
    }  
 # ------------------------------------------------ Check supplied server name  
     $course_server = $env{'user.homeserver'} if (! defined($course_server));      $course_server = $env{'user.homeserver'} if (! defined($course_server));
     if (! &is_library($course_server)) {      if (! &is_library($course_server)) {
         return 'error:bad server name '.$course_server;          return 'error:bad server name '.$course_server;
Line 6066  sub createcourse { Line 6664  sub createcourse {
     my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',      my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
                       $course_server);                        $course_server);
     unless ($reply eq 'ok') { return 'error: '.$reply; }      unless ($reply eq 'ok') { return 'error: '.$reply; }
     $uhome=&homeserver($uname,$udom,'true');      my $uhome=&homeserver($uname,$udom,'true');
     if (($uhome eq '') || ($uhome eq 'no_host')) {       if (($uhome eq '') || ($uhome eq 'no_host')) { 
  return 'error: no such course';   return 'error: no such course';
     }      }
 # ----------------------------------------------------------------- Course made  # ----------------------------------------------------------------- Course made
 # log existence  # log existence
       my $now = time;
     my $newcourse = {      my $newcourse = {
                     $udom.'_'.$uname => {                      $udom.'_'.$uname => {
                                      description => $description,                                       description => $description,
                                      inst_code   => $inst_code,                                       inst_code   => $inst_code,
                                      owner       => $course_owner,                                       owner       => $course_owner,
                                      type        => $crstype,                                       type        => $crstype,
                                        creator     => $env{'user.name'}.':'.
                                                       $env{'user.domain'},
                                        created     => $now,
                                        context     => $context,
                                                 },                                                  },
                     };                      };
     &courseidput($udom,$newcourse,$uhome,'notime');      &courseidput($udom,$newcourse,$uhome,'notime');
Line 6107  ENDINITMAP Line 6710  ENDINITMAP
     return '/'.$udom.'/'.$uname;      return '/'.$udom.'/'.$uname;
 }  }
   
   # ------------------------------------------------------------------- Create ID
   sub generate_coursenum {
       my ($udom,$crstype) = @_;
       my $domdesc = &domain($udom);
       return 'error: invalid domain' if ($domdesc eq '');
       my $first;
       if ($crstype eq 'Community') {
           $first = '0';
       } else {
           $first = int(1+rand(9)); 
       } 
       my $uname=$first.
           ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
           substr($$.time,0,5).unpack("H8",pack("I32",time)).
           unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
   # ----------------------------------------------- Make sure that does not exist
       my $uhome=&homeserver($uname,$udom,'true');
       unless (($uhome eq '') || ($uhome eq 'no_host')) {
           if ($crstype eq 'Community') {
               $first = '0';
           } else {
               $first = int(1+rand(9));
           }
           $uname=$first.
                  ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
                  substr($$.time,0,5).unpack("H8",pack("I32",time)).
                  unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
           $uhome=&homeserver($uname,$udom,'true');
           unless (($uhome eq '') || ($uhome eq 'no_host')) {
               return 'error: unable to generate unique course-ID';
           }
       }
       return $uname;
   }
   
 sub is_course {  sub is_course {
     my ($cdom,$cnum) = @_;      my ($cdom,$cnum) = @_;
     my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,      my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
Line 6117  sub is_course { Line 6755  sub is_course {
     return 0;      return 0;
 }  }
   
   sub store_userdata {
       my ($storehash,$datakey,$namespace,$udom,$uname) = @_;
       my $result;
       if ($datakey ne '') {
           if (ref($storehash) eq 'HASH') {
               if ($udom eq '' || $uname eq '') {
                   $udom = $env{'user.domain'};
                   $uname = $env{'user.name'};
               }
               my $uhome=&homeserver($uname,$udom);
               if (($uhome eq '') || ($uhome eq 'no_host')) {
                   $result = 'error: no_host';
               } else {
                   $storehash->{'ip'} = $ENV{'REMOTE_ADDR'};
                   $storehash->{'host'} = $perlvar{'lonHostID'};
   
                   my $namevalue='';
                   foreach my $key (keys(%{$storehash})) {
                       $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
                   }
                   $namevalue=~s/\&$//;
                   $result =  &reply("store:$env{'user.domain'}:$env{'user.name'}:".
                                     "$namespace:$datakey:$namevalue",$uhome);
               }
           } else {
               $result = 'error: data to store was not a hash reference'; 
           }
       } else {
           $result= 'error: invalid requestkey'; 
       }
       return $result;
   }
   
 # ---------------------------------------------------------- Assign Custom Role  # ---------------------------------------------------------- Assign Custom Role
   
 sub assigncustomrole {  sub assigncustomrole {
Line 7606  sub devalidate_title_cache { Line 8277  sub devalidate_title_cache {
     &devalidate_cache_new('title',$key);      &devalidate_cache_new('title',$key);
 }  }
   
   # ------------------------------------------------- Get the title of a course
   
   sub current_course_title {
       return $env{ 'course.' . $env{'request.course.id'} . '.description' };
   }
 # ------------------------------------------------- Get the title of a resource  # ------------------------------------------------- Get the title of a resource
   
 sub gettitle {  sub gettitle {
Line 7672  sub symblist { Line 8348  sub symblist {
     if (($env{'request.course.fn'}) && (%newhash)) {      if (($env{'request.course.fn'}) && (%newhash)) {
         if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',          if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
                       &GDBM_WRCREAT(),0640)) {                        &GDBM_WRCREAT(),0640)) {
     foreach my $url (keys %newhash) {      foreach my $url (keys(%newhash)) {
  next if ($url eq 'last_known'   next if ($url eq 'last_known'
  && $env{'form.no_update_last_known'});   && $env{'form.no_update_last_known'});
  $hash{declutter($url)}=&encode_symb($mapname,   $hash{declutter($url)}=&encode_symb($mapname,
Line 7709  sub symbverify { Line 8385  sub symbverify {
   
     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
           if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {
               $thisurl =~ s/\?.+$//;
           }
         my $ids=$bighash{'ids_'.&clutter($thisurl)};          my $ids=$bighash{'ids_'.&clutter($thisurl)};
         unless ($ids) {           unless ($ids) { 
            $ids=$bighash{'ids_/'.$thisurl};             $ids=$bighash{'ids_/'.$thisurl};
Line 7717  sub symbverify { Line 8396  sub symbverify {
 # ------------------------------------------------------------------- Has ID(s)  # ------------------------------------------------------------------- Has ID(s)
     foreach my $id (split(/\,/,$ids)) {      foreach my $id (split(/\,/,$ids)) {
        my ($mapid,$resid)=split(/\./,$id);         my ($mapid,$resid)=split(/\./,$id);
                  if ($thisfn =~ m{^/adm/wrapper/ext/}) {
                      $symb =~ s/\?.+$//;
                  }
                if (                 if (
   &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)    &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
    eq $symb) {      eq $symb) { 
Line 8593  sub declutter { Line 9275  sub declutter {
     $thisfn=~s|^adm/wrapper/||;      $thisfn=~s|^adm/wrapper/||;
     $thisfn=~s|^adm/coursedocs/showdoc/||;      $thisfn=~s|^adm/coursedocs/showdoc/||;
     $thisfn=~s/^res\///;      $thisfn=~s/^res\///;
     $thisfn=~s/\?.+$//;      unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) {
           $thisfn=~s/\?.+$//;
       }
     return $thisfn;      return $thisfn;
 }  }
   
Line 8605  sub clutter { Line 9289  sub clutter {
  || $thisfn =~ m{^/adm/(includes|pages)} ) {    || $thisfn =~ m{^/adm/(includes|pages)} ) { 
        $thisfn='/res'.$thisfn;          $thisfn='/res'.$thisfn; 
     }      }
     if ($thisfn !~m|/adm|) {      if ($thisfn !~m|^/adm|) {
  if ($thisfn =~ m|/ext/|) {   if ($thisfn =~ m|^/ext/|) {
     $thisfn='/adm/wrapper'.$thisfn;      $thisfn='/adm/wrapper'.$thisfn;
  } else {   } else {
     my ($ext) = ($thisfn =~ /\.(\w+)$/);      my ($ext) = ($thisfn =~ /\.(\w+)$/);
Line 9010  sub get_dns { Line 9694  sub get_dns {
   
  return %iphost;   return %iphost;
     }      }
 }  
   
 #      #
 #  Given a DNS returns the loncapa host name for that DNS       #  Given a DNS returns the loncapa host name for that DNS 
 #       # 
 sub host_from_dns {      sub host_from_dns {
     my ($dns) = @_;          my ($dns) = @_;
     my @hosts;          my @hosts;
     my $ip;          my $ip;
   
     $ip = gethostbyname($dns); # Initial translation to IP is in net order.          if (exists($name_to_ip{$dns})) {
     if (length($ip) == 4) {               $ip = $name_to_ip{$dns};
  $ip   = &IO::Socket::inet_ntoa($ip);          }
  @hosts = get_hosts_from_ip($ip);          if (!$ip) {
  return $hosts[0];              $ip = gethostbyname($dns); # Initial translation to IP is in net order.
               if (length($ip) == 4) { 
           $ip   = &IO::Socket::inet_ntoa($ip);
               }
           }
           if ($ip) {
       @hosts = get_hosts_from_ip($ip);
       return $hosts[0];
           }
           return undef;
     }      }
     return undef;  
 }  }
   
 BEGIN {  BEGIN {
Line 9308  in the user's environment.db and in %env Line 10000  in the user's environment.db and in %env
   
 =item *  =item *
 X<delenv()>  X<delenv()>
 B<delenv($regexp)>: removes all items from the session  B<delenv($delthis,$regexp)>: removes all items from the session
 environment file that matches the regular expression in $regexp. The  environment file that begin with $delthis. If the 
 values are also delted from the current processes %env.  optional second arg - $regexp - is true, $delthis is treated as a 
   regular expression, otherwise \Q$delthis\E is used. 
   The values are also deleted from the current processes %env.
   
 =item * get_env_multiple($name)   =item * get_env_multiple($name) 
   
Line 9407  and course level Line 10101  and course level
   
 =item *  =item *
   
 plaintext($short) : return value in %prp hash (rolesplain.tab); plain text  plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash 
 explanation of a user role term  (rolesplain.tab); plain text explanation of a user role term.
   $type is Course (default) or Community.
   If $forcedefault evaluates to true, text returned will be default 
   text for $type. Otherwise, if this is a course, the text returned 
   will be a custom name for the role (if defined in the course's 
   environment).  If no custom name is defined the default is returned.
      
 =item *  =item *
   
 get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) :  get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) :
Line 9614  database) for a course Line 10313  database) for a course
   
 =item *  =item *
   
 createcourse($udom,$description,$url) : make/modify course  createcourse($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner,$crstype,$cnum) : make course
   
   =item *
   
   generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community).
   
 =back  =back
   
Removed from v.1.986  
changed lines
  Added in v.1.1048

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