[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.957 and 1.1044

version 1.957, 2008/04/30 22:42:59 version 1.1044, 2009/11/28 19:03:36
Line 27 Line 27
 #  #
 ###  ###
   
   =pod
   
   =head1 NAME
   
   Apache::lonnet.pm
   
   =head1 SYNOPSIS
   
   This file is an interface to the lonc processes of
   the LON-CAPA network as well as set of elaborated functions for handling information
   necessary for navigating through a given cluster of LON-CAPA machines within a
   domain. There are over 40 specialized functions in this module which handle the
   reading and transmission of metadata, user information (ids, names, environments, roles,
   logs), file information (storage, reading, directories, extensions, replication, embedded
   styles and descriptors), educational resources (course descriptions, section names and
   numbers), url hashing (to assign roles on a url basis), and translating abbreviated symbols to
   and from more descriptive phrases or explanations.
   
   This is part of the LearningOnline Network with CAPA project
   described at http://www.lon-capa.org.
   
   =head1 Package Variables
   
   These are largely undocumented, so if you decipher one please note it here.
   
   =over 4
   
   =item $processmarker
   
   Contains the time this process was started and this servers host id.
   
   =item $dumpcount
   
   Counts the number of times a message log flush has been attempted (regardless
   of success) by this process.  Used as part of the filename when messages are
   delayed.
   
   =back
   
   =cut
   
 package Apache::lonnet;  package Apache::lonnet;
   
 use strict;  use strict;
 use LWP::UserAgent();  use LWP::UserAgent();
 use HTTP::Date;  use HTTP::Date;
 # use Date::Parse;  use Image::Magick;
   
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir  use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
             $_64bit %env);              $_64bit %env %protocol);
   
 my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,  my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
     %userrolehash, $processmarker, $dumpcount, %coursedombuf,      %userrolehash, $processmarker, $dumpcount, %coursedombuf,
     %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,      %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,
     %courseownerbuf, %coursetypebuf);      %courseownerbuf, %coursetypebuf,$locknum);
   
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
Line 50  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;
   
 my $readit;  my $readit;
 my $max_connection_retries = 10;     # Or some such value.  my $max_connection_retries = 10;     # Or some such value.
   
   my $upload_photo_form = 0; #Variable to check  when user upload a photo 0=not 1=true
   
 require Exporter;  require Exporter;
   
 our @ISA = qw (Exporter);  our @ISA = qw (Exporter);
 our @EXPORT = qw(%env);  our @EXPORT = qw(%env);
   
 =pod  
   
 =head1 Package Variables  
   
 These are largely undocumented, so if you decipher one please note it here.  
   
 =over 4  
   
 =item $processmarker  
   
 Contains the time this process was started and this servers host id.  
   
 =item $dumpcount  
   
 Counts the number of times a message log flush has been attempted (regardless  
 of success) by this process.  Used as part of the filename when messages are  
 delayed.  
   
 =back  
   
 =cut  
   
   
 # --------------------------------------------------------------------- Logging  # --------------------------------------------------------------------- Logging
 {  {
Line 127  sub logthis { Line 150  sub logthis {
     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")) {
  print $fh "$local ($$): $message\n";   my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.
    print $fh $logstring;
  close($fh);   close($fh);
     }      }
     return 1;      return 1;
Line 158  sub create_connection { Line 182  sub create_connection {
     return 0;      return 0;
 }  }
   
   sub get_server_timezone {
       my ($cnum,$cdom) = @_;
       my $home=&homeserver($cnum,$cdom);
       if ($home ne 'no_host') {
           my $cachetime = 24*3600;
           my ($timezone,$cached)=&is_cached_new('servertimezone',$home);
           if (defined($cached)) {
               return $timezone;
           } else {
               my $timezone = &reply('servertimezone',$home);
               return &do_cache_new('servertimezone',$home,$timezone,$cachetime);
           }
       }
   }
   
   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 {
Line 489  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 502  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=~/^$delthis/) {       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 526  sub get_env_multiple { Line 598  sub get_env_multiple {
     return(@values);      return(@values);
 }  }
   
   # ------------------------------------------------------------------- Locking
   
   sub set_lock {
       my ($text)=@_;
       $locknum++;
       my $id=$$.'-'.$locknum;
       &appenv({'session.locks' => $env{'session.locks'}.','.$id,
                'session.lock.'.$id => $text});
       return $id;
   }
   
   sub get_locks {
       my $num=0;
       my %texts=();
       foreach my $lock (split(/\,/,$env{'session.locks'})) {
          if ($lock=~/\w/) {
             $num++;
             $texts{$lock}=$env{'session.lock.'.$lock};
          }
      }
      return ($num,%texts);
   }
   
   sub remove_lock {
       my ($id)=@_;
       my $newlocks='';
       foreach my $lock (split(/\,/,$env{'session.locks'})) {
          if (($lock=~/\w/) && ($lock ne $id)) {
             $newlocks.=','.$lock;
          }
       }
       &appenv({'session.locks' => $newlocks});
       &delenv('session.lock.'.$id);
   }
   
   sub remove_all_locks {
       my $activelocks=$env{'session.locks'};
       foreach my $lock (split(/\,/,$env{'session.locks'})) {
          if ($lock=~/\w/) {
             &remove_lock($lock);
          }
       }
   }
   
   
 # ------------------------------------------ Find out current server userload  # ------------------------------------------ Find out current server userload
 sub userload {  sub userload {
     my $numusers=0;      my $numusers=0;
Line 598  sub spareserver { Line 715  sub spareserver {
     }      }
   
     if (!$want_server_name) {      if (!$want_server_name) {
  $spare_server="http://".&hostname($spare_server);          my $protocol = 'http';
           if ($protocol{$spare_server} eq 'https') {
               $protocol = $protocol{$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 659  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 684  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 833  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 907  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')) {
         my ($hashitems,$orderitems) = split(/:/,$rep);           %returnhash = %{$domdefs{'inststatustypes'}};
         my @pairs=split(/\&/,$hashitems);          @order = @{$domdefs{'inststatusorder'}};
         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 1150  sub inst_userrules { Line 1339  sub inst_userrules {
     return (\%ruleshash,\@ruleorder);      return (\%ruleshash,\@ruleorder);
 }  }
   
 # ------------------------- Get Authentication and Language Defaults for Domain  # ------------- Get Authentication, Language and User Tools Defaults for Domain
   
 sub get_domain_defaults {  sub get_domain_defaults {
     my ($domain) = @_;      my ($domain) = @_;
     my $cachetime = 60*60*24;      my $cachetime = 60*60*24;
     my ($defauthtype,$defautharg,$deflang);  
     my ($result,$cached)=&is_cached_new('domdefaults',$domain);      my ($result,$cached)=&is_cached_new('domdefaults',$domain);
     if (defined($cached)) {      if (defined($cached)) {
         if (ref($result) eq 'HASH') {          if (ref($result) eq 'HASH') {
Line 1164  sub get_domain_defaults { Line 1352  sub get_domain_defaults {
     }      }
     my %domdefaults;      my %domdefaults;
     my %domconfig =      my %domconfig =
          &Apache::lonnet::get_dom('configuration',['defaults'],$domain);           &Apache::lonnet::get_dom('configuration',['defaults','quotas',
                                     'requestcourses','inststatus'],$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'};
         $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};          $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
           $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
           $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
     } 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');
         $domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def');          $domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def');
     }      }
       if (ref($domconfig{'quotas'}) eq 'HASH') {
           if (ref($domconfig{'quotas'}{'defaultquota'}) eq 'HASH') {
               $domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'};
           } else {
               $domdefaults{'defaultquota'} = $domconfig{'quotas'};
           } 
           my @usertools = ('aboutme','blog','portfolio');
           foreach my $item (@usertools) {
               if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
                   $domdefaults{$item} = $domconfig{'quotas'}{$item};
               }
           }
       }
       if (ref($domconfig{'requestcourses'}) eq 'HASH') {
           foreach my $item ('official','unofficial','community') {
               $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
           }
       }
       if (ref($domconfig{'inststatus'}) eq 'HASH') {
           foreach my $item ('inststatustypes','inststatusorder') {
               $domdefaults{$item} = $domconfig{'inststatus'}{$item};
           }
       }
     &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,      &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
                                   $cachetime);                                    $cachetime);
     return %domdefaults;      return %domdefaults;
Line 1498  sub purge_remembered { Line 1712  sub purge_remembered {
   
 sub userenvironment {  sub userenvironment {
     my ($udom,$unam,@what)=@_;      my ($udom,$unam,@what)=@_;
       my $items;
       foreach my $item (@what) {
           $items.=&escape($item).'&';
       }
       $items=~s/\&$//;
     my %returnhash=();      my %returnhash=();
     my @answer=split(/\&/,      my $uhome = &homeserver($unam,$udom);
                 &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),      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++) {          my $i;
  $returnhash{$what[$i]}=&unescape($answer[$i]);          for ($i=0;$i<=$#what;$i++) {
       $returnhash{$what[$i]}=&unescape($answer[$i]);
           }
     }      }
     return %returnhash;      return %returnhash;
 }  }
Line 1697  sub ssi_body { Line 1918  sub ssi_body {
     }      }
     my $output='';      my $output='';
     my $response;      my $response;
     if ($filelink=~/^http\:/) {      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 1743  sub ssi { Line 1966  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 1841  sub process_coursefile { Line 2064  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 1920  sub clean_filename { Line 2147  sub clean_filename {
     $fname=~s/\.(\d+)(?=\.)/_$1/g;      $fname=~s/\.(\d+)(?=\.)/_$1/g;
     return $fname;      return $fname;
 }  }
   #This Function check if a Image max 400px width and height 500px. If not then scale the image down
   sub resizeImage {
    my($img_url) = @_;
    my $ima = Image::Magick->new;                       
           $ima->Read($img_url);
    if($ima->Get('width') > 400)
    {
    my $factor = $ima->Get('width')/400;
                 $ima->Scale( width=>400, height=>$ima->Get('height')/$factor );
    }
    if($ima->Get('height') > 500)
           {
           my $factor = $ima->Get('height')/500;
                   $ima->Scale( width=>$ima->Get('width')/$factor, height=>500);
           } 
   
    $ima->Write($img_url);
   }
   
   #Wrapper function for userphotoupload
   sub userphotoupload
   {
    my($formname,$subdir) = @_;
    $upload_photo_form = 1;
    return &userfileupload($formname,undef,$subdir);
   }
   
 # --------------- Take an uploaded file and put it into the userfiles directory  # --------------- Take an uploaded file and put it into the userfiles directory
 # input: $formname - the contents of the file are in $env{"form.$formname"}  # input: $formname - the contents of the file are in $env{"form.$formname"}
Line 1979  sub userfileupload { Line 2232  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 2020  sub finishuserfileupload { Line 2276  sub finishuserfileupload {
         $thumbwidth,$thumbheight) = @_;          $thumbwidth,$thumbheight) = @_;
     my $path=$docudom.'/'.$docuname.'/';      my $path=$docudom.'/'.$docuname.'/';
     my $filepath=$perlvar{'lonDocRoot'};      my $filepath=$perlvar{'lonDocRoot'};
     
     my ($fnamepath,$file,$fetchthumb);      my ($fnamepath,$file,$fetchthumb);
     $file=$fname;      $file=$fname;
     if ($fname=~m|/|) {      if ($fname=~m|/|) {
Line 2034  sub finishuserfileupload { Line 2291  sub finishuserfileupload {
     mkdir($filepath,0777);      mkdir($filepath,0777);
         }          }
     }      }
   
 # Save the file  # Save the file
     {      {
  if (!open(FH,'>'.$filepath.'/'.$file)) {   if (!open(FH,'>'.$filepath.'/'.$file)) {
Line 2047  sub finishuserfileupload { Line 2305  sub finishuserfileupload {
     return '/adm/notfound.html';      return '/adm/notfound.html';
  }   }
  close(FH);   close(FH);
    if($upload_photo_form==1)
    {
    resizeImage($filepath.'/'.$file);
    $upload_photo_form = 0;
    }
     }      }
     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 2068  sub finishuserfileupload { Line 2335  sub finishuserfileupload {
     
 # Notify homeserver to grep it  # Notify homeserver to grep it
 #  #
     my $docuhome=&homeserver($docuname,$docudom);      my $docuhome=&homeserver($docuname,$docudom);
     my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);      my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
     if ($fetchresult eq 'ok') {      if ($fetchresult eq 'ok') {
         if ($fetchthumb) {          if ($fetchthumb) {
Line 2089  sub finishuserfileupload { Line 2356  sub finishuserfileupload {
 }  }
   
 sub extract_embedded_items {  sub extract_embedded_items {
     my ($filepath,$file,$allfiles,$codebase,$content) = @_;      my ($fullpath,$allfiles,$codebase,$content) = @_;
     my @state = ();      my @state = ();
     my %javafiles = (      my %javafiles = (
                       codebase => '',                        codebase => '',
Line 2104  sub extract_embedded_items { Line 2371  sub extract_embedded_items {
     if ($content) {      if ($content) {
         $p = HTML::LCParser->new($content);          $p = HTML::LCParser->new($content);
     } else {      } else {
         $p = HTML::LCParser->new($filepath.'/'.$file);          $p = HTML::LCParser->new($fullpath);
     }      }
     while (my $t=$p->get_token()) {      while (my $t=$p->get_token()) {
  if ($t->[0] eq 'S') {   if ($t->[0] eq 'S') {
Line 2200  sub add_filetype { Line 2467  sub add_filetype {
 }  }
   
 sub removeuploadedurl {  sub removeuploadedurl {
     my ($url)=@_;      my ($url)=@_;
     my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);      my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);    
     return &removeuserfile($uname,$udom,$fname);      return &removeuserfile($uname,$udom,$fname);
 }  }
   
 sub removeuserfile {  sub removeuserfile {
     my ($docuname,$docudom,$fname)=@_;      my ($docuname,$docudom,$fname)=@_;
     my $home=&homeserver($docuname,$docudom);      my $home=&homeserver($docuname,$docudom);    
     my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);      my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
     if ($result eq 'ok') {      if ($result eq 'ok') {
         if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {          if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
             my $metafile = $fname.'.meta';              my $metafile = $fname.'.meta';
             my $metaresult = &removeuserfile($docuname,$docudom,$metafile);               my $metaresult = &removeuserfile($docuname,$docudom,$metafile); 
     my $url = "/uploaded/$docudom/$docuname/$fname";      my $url = "/uploaded/$docudom/$docuname/$fname";
             my ($file,$group) = (&parse_portfolio_url($url))[3,4];              my ($file,$group) = (&parse_portfolio_url($url))[3,4];   
             my $sqlresult =               my $sqlresult = 
                 &update_portfolio_table($docuname,$docudom,$file,                  &update_portfolio_table($docuname,$docudom,$file,
                                         'portfolio_metadata',$group,                                          'portfolio_metadata',$group,
Line 2357  sub flushcourselogs { Line 2624  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 2417  sub courseacclog { Line 2684  sub courseacclog {
         # FIXME: Probably ought to escape things....          # FIXME: Probably ought to escape things....
  foreach my $key (keys(%env)) {   foreach my $key (keys(%env)) {
             if ($key=~/^form\.(.*)/) {              if ($key=~/^form\.(.*)/) {
  $what.=':'.$1.'='.$env{$key};                  my $formitem = $1;
                   if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) {
                       $what.=':'.$formitem.'='.$env{$key};
                   } elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {
                       $what.=':'.$formitem.'='.$env{$key};
                   }
             }              }
         }          }
     } elsif ($fnsymb =~ m:^/adm/searchcat:) {      } elsif ($fnsymb =~ m:^/adm/searchcat:) {
Line 2457  sub userrolelog { Line 2729  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 2466  sub userrolelog { Line 2738  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 2487  sub courserolelog { Line 2760  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 2507  sub courserolelog { Line 2781  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 2516  sub get_course_adv_roles { Line 2793  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 2528  sub get_course_adv_roles { Line 2806  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 2546  sub get_course_adv_roles { Line 2838  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.=' (Section '.$section.')'; }              if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; }
             if ($returnhash{$key}) {              if ($returnhash{$key}) {
         $returnhash{$key}.=','.$username.':'.$domain;          $returnhash{$key}.=','.$username.':'.$domain;
             } else {              } else {
Line 2581  sub get_my_roles { Line 2873  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 2629  sub get_my_roles { Line 2922  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 2717  sub courseidput { Line 3033  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)=@_;          $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 2735  sub courseiddump { Line 3052  sub courseiddump {
                          &escape($instcodefilter).':'.&escape($ownerfilter).                           &escape($instcodefilter).':'.&escape($ownerfilter).
                          ':'.&escape($coursefilter).':'.&escape($typefilter).                           ':'.&escape($coursefilter).':'.&escape($typefilter).
                          ':'.&escape($regexp_ok).':'.$as_hash.':'.                           ':'.&escape($regexp_ok).':'.$as_hash.':'.
                          &escape($selfenrollonly),$tryserver);                           &escape($selfenrollonly).':'.&escape($catfilter).':'.
                            $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 2750  sub courseiddump { Line 3071  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 2790  sub dcmaildump { Line 3111  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 3200  sub tmpreset { Line 3521  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 3483  sub privileged { Line 3804  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 3511  sub privileged { Line 3835  sub privileged {
   
 sub rolesinit {  sub rolesinit {
     my ($domain,$username,$authhost)=@_;      my ($domain,$username,$authhost)=@_;
       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 ''; }      if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || 
           ($rolesdump =~ /^error:/)) { 
           return \%userroles;
       }
     my %allroles=();      my %allroles=();
     my %allgroups=();         my %allgroups=();   
     my $now=time;  
     my %userroles = ('user.login.time' => $now);  
     my $group_privs;      my $group_privs;
   
     if ($rolesdump ne '') {      if ($rolesdump ne '') {
Line 3582  sub custom_roleprivs { Line 3909  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 3635  sub set_userprivs { Line 3965  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 3678  sub set_userprivs { Line 4008  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 3713  sub del { Line 4138  sub del {
    foreach my $item (@$storearr) {     foreach my $item (@$storearr) {
        $items.=&escape($item).'&';         $items.=&escape($item).'&';
    }     }
   
    $items=~s/\&$//;     $items=~s/\&$//;
    if (!$udomain) { $udomain=$env{'user.domain'}; }     if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$env{'user.name'}; }     if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
   
    return &reply("del:$udomain:$uname:$namespace:$items",$uhome);     return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
 }  }
   
Line 4277  sub is_portfolio_file { Line 4702  sub is_portfolio_file {
     return;      return;
 }  }
   
   sub usertools_access {
       my ($uname,$udom,$tool,$action,$context) = @_;
       my ($access,%tools);
       if ($context eq '') {
           $context = 'tools';
       }
       if ($context eq 'requestcourses') {
           %tools = (
                         official   => 1,
                         unofficial => 1,
                         community  => 1,
                    );
       } else {
           %tools = (
                         aboutme   => 1,
                         blog      => 1,
                         portfolio => 1,
                    );
       }
       return if (!defined($tools{$tool}));
   
       if ((!defined($udom)) || (!defined($uname))) {
           $udom = $env{'user.domain'};
           $uname = $env{'user.name'};
       }
   
       if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
           if ($action ne 'reload') {
               if ($context eq 'requestcourses') {
                   return $env{'environment.canrequest.'.$tool};
               } else {
                   return $env{'environment.availabletools.'.$tool};
               }
           }
       }
   
       my ($toolstatus,$inststatus);
   
       if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
            ($action ne 'reload')) {
           $toolstatus = $env{'environment.'.$context.'.'.$tool};
           $inststatus = $env{'environment.inststatus'};
       } else {
           my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');
           $toolstatus = $userenv{$context.'.'.$tool};
           $inststatus = $userenv{'inststatus'};
       }
   
       if ($toolstatus ne '') {
           if ($toolstatus) {
               $access = 1;
           } else {
               $access = 0;
           }
           return $access;
       }
   
       my $is_adv = &is_advanced_user($udom,$uname);
       my %domdef = &get_domain_defaults($udom);
       if (ref($domdef{$tool}) eq 'HASH') {
           if ($is_adv) {
               if ($domdef{$tool}{'_LC_adv'} ne '') {
                   if ($domdef{$tool}{'_LC_adv'}) { 
                       $access = 1;
                   } else {
                       $access = 0;
                   }
                   return $access;
               }
           }
           if ($inststatus ne '') {
               my ($hasaccess,$hasnoaccess);
               foreach my $affiliation (split(/:/,$inststatus)) {
                   if ($domdef{$tool}{$affiliation} ne '') { 
                       if ($domdef{$tool}{$affiliation}) {
                           $hasaccess = 1;
                       } else {
                           $hasnoaccess = 1;
                       }
                   }
               }
               if ($hasaccess || $hasnoaccess) {
                   if ($hasaccess) {
                       $access = 1;
                   } elsif ($hasnoaccess) {
                       $access = 0; 
                   }
                   return $access;
               }
           } else {
               if ($domdef{$tool}{'default'} ne '') {
                   if ($domdef{$tool}{'default'}) {
                       $access = 1;
                   } elsif ($domdef{$tool}{'default'} == 0) {
                       $access = 0;
                   }
                   return $access;
               }
           }
       } else {
           if ($context eq 'tools') {
               $access = 1;
           } else {
               $access = 0;
           }
           return $access;
       }
   }
   
   sub is_advanced_user {
       my ($udom,$uname) = @_;
       my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
       my %allroles;
       my $is_adv;
       foreach my $role (keys(%roleshash)) {
           my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);
           my $area = '/'.$tdomain.'/'.$trest;
           if ($sec ne '') {
               $area .= '/'.$sec;
           }
           if (($area ne '') && ($trole ne '')) {
               my $spec=$trole.'.'.$area;
               if ($trole =~ /^cr\//) {
                   &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
               } elsif ($trole ne 'gr') {
                   &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
               }
           }
       }
       foreach my $role (keys(%allroles)) {
           last if ($is_adv);
           foreach my $item (split(/:/,$allroles{$role})) {
               if ($item ne '') {
                   my ($privilege,$restrictions)=split(/&/,$item);
                   if ($privilege eq 'adv') {
                       $is_adv = 1;
                       last;
                   }
               }
           }
       }
       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
   
Line 4432  sub allowed { Line 5049  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 4452  sub allowed { Line 5120  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 4489  sub allowed { Line 5159  sub allowed {
     }      }
           
 # Full access at system, domain or course-wide level? Exit.  # Full access at system, domain or course-wide level? Exit.
   
     if ($thisallowed=~/F/) {      if ($thisallowed=~/F/) {
  return 'F';   return 'F';
     }      }
Line 4593  sub allowed { Line 5262  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 4842  sub log_query { Line 5511  sub log_query {
   
 sub update_portfolio_table {  sub update_portfolio_table {
     my ($uname,$udom,$file_name,$query,$group,$action) = @_;      my ($uname,$udom,$file_name,$query,$group,$action) = @_;
       if ($group ne '') {
           $file_name =~s /^\Q$group\E//;
       }
     my $homeserver = &homeserver($uname,$udom);      my $homeserver = &homeserver($uname,$udom);
     my $queryid=      my $queryid=
         &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).          &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
Line 4881  sub fetch_enrollment_query { Line 5553  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 5014  sub auto_run { Line 5686  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 5037  sub auto_validate_courseID { Line 5719  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 5151  sub auto_instcode_format { Line 5850  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 5208  sub auto_instcode_defaults { Line 5914  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 5361  sub devalidate_getgroups_cache { Line 6141  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 =~ /^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 5395  sub assignrole { Line 6185  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 5426  sub assignrole { Line 6233  sub assignrole {
             if ($refused) {              if ($refused) {
                 if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {                  if (($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 ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
                           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 5509  sub modifyuser { Line 6335  sub modifyuser {
     my ($udom,    $uname, $uid,      my ($udom,    $uname, $uid,
         $umode,   $upass, $first,          $umode,   $upass, $first,
         $middle,  $last,  $gene,          $middle,  $last,  $gene,
         $forceid, $desiredhome, $email)=@_;          $forceid, $desiredhome, $email, $inststatus)=@_;
     $udom= &LONCAPA::clean_domain($udom);      $udom= &LONCAPA::clean_domain($udom);
     $uname=&LONCAPA::clean_username($uname);      $uname=&LONCAPA::clean_username($uname);
     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
Line 5570  sub modifyuser { Line 6396  sub modifyuser {
 # -------------------------------------------------------------- Add names, etc  # -------------------------------------------------------------- Add names, etc
     my @tmp=&get('environment',      my @tmp=&get('environment',
    ['firstname','middlename','lastname','generation','id',     ['firstname','middlename','lastname','generation','id',
                     'permanentemail'],                      'permanentemail','inststatus'],
    $udom,$uname);     $udom,$uname);
     my %names;      my %names;
     if ($tmp[0] =~ m/^error:.*/) {       if ($tmp[0] =~ m/^error:.*/) { 
Line 5588  sub modifyuser { Line 6414  sub modifyuser {
     if (defined($gene))   { $names{'generation'} = $gene; }      if (defined($gene))   { $names{'generation'} = $gene; }
     if ($email) {      if ($email) {
        $email=~s/[^\w\@\.\-\,]//gs;         $email=~s/[^\w\@\.\-\,]//gs;
        if ($email=~/\@/) { $names{'notification'} = $email;         if ($email=~/\@/) { $names{'permanentemail'} = $email; }
    $names{'critnotification'} = $email;  
    $names{'permanentemail'} = $email; }  
     }      }
     if ($uid) { $names{'id'}  = $uid; }      if ($uid) { $names{'id'}  = $uid; }
       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);
     &devalidate_cache_new('namescache',$uname.':'.$udom);      &devalidate_cache_new('namescache',$uname.':'.$udom);
     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.      my $logmsg = 'Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
              $umode.', '.$first.', '.$middle.', '.                   $umode.', '.$first.', '.$middle.', '.
      $last.', '.$gene.' by '.           $last.', '.$gene.', '.$email.', '.$inststatus;
              $env{'user.name'}.' at '.$env{'user.domain'});      if ($env{'user.name'} ne '' && $env{'user.domain'}) {
           $logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'};
       } else {
           $logmsg .= ' during self creation';
       }
       &logthis($logmsg);
     return 'ok';      return 'ok';
 }  }
   
Line 5609  sub modifyuser { Line 6453  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 5618  sub modifystudent { Line 6462  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 5732  sub writecoursepref { Line 6576  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 5762  sub createcourse { Line 6635  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 5803  ENDINITMAP Line 6681  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 5813  sub is_course { Line 6726  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 5826  sub assigncustomrole { Line 6772  sub assigncustomrole {
 sub revokerole {  sub revokerole {
     my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_;      my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_;
     my $now=time;      my $now=time;
     return &assignrole($udom,$uname,$url,$role,$now,$deleteflag,$selfenroll,$context);      return &assignrole($udom,$uname,$url,$role,$now,undef,$deleteflag,$selfenroll,$context);
 }  }
   
 # ---------------------------------------------------------- Revoke Custom Role  # ---------------------------------------------------------- Revoke Custom Role
Line 6091  sub modify_access_controls { Line 7037  sub modify_access_controls {
                 }                  }
             }              }
         }          }
           my ($group);
           if (&is_course($domain,$user)) {
               ($group,my $file) = split(/\//,$file_name,2);
           }
         $deloutcome = &del('file_permissions',\@deletions,$domain,$user);          $deloutcome = &del('file_permissions',\@deletions,$domain,$user);
         $new_values{$file_name."\0".'accesscontrol'} = \%new_control;          $new_values{$file_name."\0".'accesscontrol'} = \%new_control;
         $outcome = &put('file_permissions',\%new_values,$domain,$user);          $outcome = &put('file_permissions',\%new_values,$domain,$user);
         #  remove lock          #  remove lock
         my @del_lock = ($file_name."\0".'locked_access_records');          my @del_lock = ($file_name."\0".'locked_access_records');
         my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);          my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
         my ($file,$group);  
         if (&is_course($domain,$user)) {  
             ($group,$file) = split(/\//,$file_name,2);  
         } else {  
             $file = $file_name;  
         }  
         my $sqlresult =          my $sqlresult =
             &update_portfolio_table($user,$domain,$file,'portfolio_access',              &update_portfolio_table($user,$domain,$file_name,'portfolio_access',
                                     $group);                                      $group);
     } else {      } else {
         $outcome = "error: could not obtain lockfile\n";            $outcome = "error: could not obtain lockfile\n";  
Line 7304  sub devalidate_title_cache { Line 8248  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 7370  sub symblist { Line 8319  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 7407  sub symbverify { Line 8356  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 7415  sub symbverify { Line 8367  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 8077  sub repcopy_userfile { Line 9032  sub repcopy_userfile {
     if (-e $transferfile) { return 'ok'; }      if (-e $transferfile) { return 'ok'; }
     my $request;      my $request;
     $uri=~s/^\///;      $uri=~s/^\///;
     $request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);      my $homeserver = &homeserver($cnum,$cdom);
       my $protocol = $protocol{$homeserver};
       $protocol = 'http' if ($protocol ne 'https');
       $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri);
     my $response=$ua->request($request,$transferfile);      my $response=$ua->request($request,$transferfile);
 # did it work?  # did it work?
     if ($response->is_error()) {      if ($response->is_error()) {
Line 8092  sub repcopy_userfile { Line 9050  sub repcopy_userfile {
   
 sub tokenwrapper {  sub tokenwrapper {
     my $uri=shift;      my $uri=shift;
     $uri=~s|^http\://([^/]+)||;      $uri=~s|^https?\://([^/]+)||;
     $uri=~s|^/||;      $uri=~s|^/||;
     $env{'user.environment'}=~/\/([^\/]+)\.id/;      $env{'user.environment'}=~/\/([^\/]+)\.id/;
     my $token=$1;      my $token=$1;
Line 8100  sub tokenwrapper { Line 9058  sub tokenwrapper {
     if ($udom && $uname && $file) {      if ($udom && $uname && $file) {
  $file=~s|(\?\.*)*$||;   $file=~s|(\?\.*)*$||;
         &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});          &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
         return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.          my $homeserver = &homeserver($uname,$udom);
           my $protocol = $protocol{$homeserver};
           $protocol = 'http' if ($protocol ne 'https');
           return $protocol.'://'.&hostname($homeserver).'/'.$uri.
                (($uri=~/\?/)?'&':'?').'token='.$token.                 (($uri=~/\?/)?'&':'?').'token='.$token.
                                '&tokenissued='.$perlvar{'lonHostID'};                                 '&tokenissued='.$perlvar{'lonHostID'};
     } else {      } else {
Line 8115  sub tokenwrapper { Line 9076  sub tokenwrapper {
 sub getuploaded {  sub getuploaded {
     my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;      my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
     $uri=~s/^\///;      $uri=~s/^\///;
     $uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri;      my $homeserver = &homeserver($cnum,$cdom);
       my $protocol = $protocol{$homeserver};
       $protocol = 'http' if ($protocol ne 'https');
       $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
     my $request=new HTTP::Request($reqtype,$uri);      my $request=new HTTP::Request($reqtype,$uri);
     my $response=$ua->request($request);      my $response=$ua->request($request);
Line 8197  sub filelocation { Line 9161  sub filelocation {
   
 sub hreflocation {  sub hreflocation {
     my ($dir,$file)=@_;      my ($dir,$file)=@_;
     unless (($file=~m-^http://-i) || ($file=~m-^/-)) {      unless (($file=~m-^https?\://-i) || ($file=~m-^/-)) {
  $file=filelocation($dir,$file);   $file=filelocation($dir,$file);
     } elsif ($file=~m-^/adm/-) {      } elsif ($file=~m-^/adm/-) {
  $file=~s-^/adm/wrapper/-/-;   $file=~s-^/adm/wrapper/-/-;
Line 8282  sub declutter { Line 9246  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 8294  sub clutter { Line 9260  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 8393  sub get_dns { Line 9359  sub get_dns {
     open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");      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);
  $alldns{$1} = 1;          my $line = $1;
           my ($host,$protocol) = split(/:/,$line);
           if ($protocol ne 'https') {
               $protocol = 'http';
           }
    $alldns{$host} = $protocol;
     }      }
     while (%alldns) {      while (%alldns) {
  my ($dns) = keys(%alldns);   my ($dns) = keys(%alldns);
  delete($alldns{$dns});  
  my $ua=new LWP::UserAgent;   my $ua=new LWP::UserAgent;
  my $request=new HTTP::Request('GET',"http://$dns$url");   my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
  my $response=$ua->request($request);   my $response=$ua->request($request);
           delete($alldns{$dns});
  next if ($response->is_error());   next if ($response->is_error());
  my @content = split("\n",$response->content);   my @content = split("\n",$response->content);
  &Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60);   &Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60);
Line 8465  sub get_dns { Line 9436  sub get_dns {
  }   }
  return $domain{$name}{$what};   return $domain{$name}{$what};
     }      }
   
       sub domain_info {
           &load_domain_tab() if (!$loaded);
           return %domain;
       }
   
 }  }
   
   
Line 8482  sub get_dns { Line 9459  sub get_dns {
     next if ($configline =~ /^(\#|\s*$ )/x);      next if ($configline =~ /^(\#|\s*$ )/x);
     next if ($configline =~ /^\^/);      next if ($configline =~ /^\^/);
     chomp($configline);      chomp($configline);
     my ($id,$domain,$role,$name)=split(/:/,$configline);      my ($id,$domain,$role,$name,$protocol)=split(/:/,$configline);
     $name=~s/\s//g;      $name=~s/\s//g;
     if ($id && $domain && $role && $name) {      if ($id && $domain && $role && $name) {
  $hostname{$id}=$name;   $hostname{$id}=$name;
  push(@{$name_to_host{$name}}, $id);   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 ($protocol eq 'https') {
                           $protocol{$id} = $protocol;
                       } else {
                           $protocol{$id} = 'http'; 
                       }
                   } else {
                       $protocol{$id} = 'http';
                   }
     }      }
  }   }
     }      }
Line 8533  sub get_dns { Line 9519  sub get_dns {
  return %name_to_host;   return %name_to_host;
     }      }
   
       sub all_host_domain {
           &load_hosts_tab() if (!$loaded);
           return %hostdom;
       }
   
     sub is_library {      sub is_library {
  &load_hosts_tab() if (!$loaded);   &load_hosts_tab() if (!$loaded);
   
Line 8674  sub get_dns { Line 9665  sub get_dns {
   
  return %iphost;   return %iphost;
     }      }
   
       #
       #  Given a DNS returns the loncapa host name for that DNS 
       # 
       sub host_from_dns {
           my ($dns) = @_;
           my @hosts;
           my $ip;
   
           if (exists($name_to_ip{$dns})) {
               $ip = $name_to_ip{$dns};
           }
           if (!$ip) {
               $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;
       }
   
 }  }
   
 BEGIN {  BEGIN {
Line 8763  $memcache=new Cache::Memcached({'servers Line 9779  $memcache=new Cache::Memcached({'servers
   
 $processmarker='_'.time.'_'.$perlvar{'lonHostID'};  $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
 $dumpcount=0;  $dumpcount=0;
   $locknum=0;
   
 &logtouch();  &logtouch();
 &logthis('<font color="yellow">INFO: Read configuration</font>');  &logthis('<font color="yellow">INFO: Read configuration</font>');
Line 8930  when the connection is brought back up Line 9947  when the connection is brought back up
 =item * B<con_failed>: unable to contact remote host and unable to save message  =item * B<con_failed>: unable to contact remote host and unable to save message
 for later delivery  for later delivery
   
 =item * B<error:>: an error a occured, a description of the error follows the :  =item * B<error:>: an error a occurred, a description of the error follows the :
   
 =item * B<no_such_host>: unable to fund a host associated with the user/domain  =item * B<no_such_host>: unable to fund a host associated with the user/domain
 that was requested  that was requested
Line 8954  in the user's environment.db and in %env Line 9971  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 9053  and course level Line 10072  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 9097  modifyuserauth($udom,$uname,$umode,$upas Line 10121  modifyuserauth($udom,$uname,$umode,$upas
   
 =item *  =item *
   
 modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) :   modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,
              $forceid,$desiredhome,$email,$inststatus) : 
 modify user  modify user
   
 =item *  =item *
Line 9120  Inputs: Line 10145  Inputs:
   
 =item B<$uname> Student's loncapa login name  =item B<$uname> Student's loncapa login name
   
 =item B<$uid> Student's id/student number  =item B<$uid> Student/Employee ID
   
 =item B<$umode> Student's authentication mode  =item B<$umode> Student's authentication mode
   
Line 9148  Inputs: Line 10173  Inputs:
   
 =item B<$type> Type of enrollment (auto or manual)  =item B<$type> Type of enrollment (auto or manual)
   
 =item B<$locktype>  =item B<$locktype> boolean - enrollment type locked to prevent Autoenroll.pl changing manual to auto    
   
 =item B<$cid>  =item B<$cid> courseID - needed if a course role is assigned by a user whose current role is DC
   
 =item B<$selfenroll>  =item B<$selfenroll> boolean - 1 if user role change occurred via self-enrollment
   
 =item B<$context>  =item B<$context> role change context (shown in User Management Logs display in a course)
   
   =item B<$inststatus> institutional status of user - : separated string of escaped status types  
   
 =back  =back
   
Line 9257  database) for a course Line 10284  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
   
Line 9507  Returns: Line 10538  Returns:
  'key_exists: <key>' -> failed to anything out of $storehash, as at   'key_exists: <key>' -> failed to anything out of $storehash, as at
                         least <key> already existed in the db (other                          least <key> already existed in the db (other
                         requested keys may also already exist)                          requested keys may also already exist)
  'error: <msg>' -> unable to tie the DB or other erorr occured   'error: <msg>' -> unable to tie the DB or other error occurred
  'con_lost' -> unable to contact request server   'con_lost' -> unable to contact request server
  'refused' -> action was not allowed by remote machine   'refused' -> action was not allowed by remote machine
   
Line 9561  dirlist($uri) : return directory list ba Line 10592  dirlist($uri) : return directory list ba
   
 spareserver() : find server with least workload from spare.tab  spareserver() : find server with least workload from spare.tab
   
   
   =item *
   
   host_from_dns($dns) : Returns the loncapa hostname corresponding to a DNS name or undef
   if there is no corresponding loncapa host.
   
 =back  =back
   
   
 =head2 Apache Request  =head2 Apache Request
   
 =over 4  =over 4
Removed from v.1.957  
changed lines
  Added in v.1.1044

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