[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.970 and 1.1004

version 1.970, 2008/10/08 21:14:11 version 1.1004, 2009/07/17 13:55:10
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 %protocol);              $_64bit %env %protocol);
   
Line 56  use LONCAPA::Configuration; Line 98  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 149  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 181  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 553  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 566  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 647  sub spareserver { Line 718  sub spareserver {
         if ($protocol{$spare_server} eq 'https') {          if ($protocol{$spare_server} eq 'https') {
             $protocol = $protocol{$spare_server};              $protocol = $protocol{$spare_server};
         }          }
  $spare_server = $protocol.'://'.&hostname($spare_server);          if (defined($spare_server)) {
               my $hostname = &hostname($spare_server);
               if (defined($hostname)) {  
           $spare_server = $protocol.'://'.$hostname;
               }
           }
     }      }
     return $spare_server;      return $spare_server;
 }  }
Line 959  sub put_dom { Line 1035  sub put_dom {
 sub retrieve_inst_usertypes {  sub retrieve_inst_usertypes {
     my ($udom) = @_;      my ($udom) = @_;
     my (%returnhash,@order);      my (%returnhash,@order);
     if (defined(&domain($udom,'primary'))) {      my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
         my $uhome=&domain($udom,'primary');      if ((ref($domdefs{'inststatustypes'}) eq 'HASH') && 
         my $rep=&reply("inst_usertypes:$udom",$uhome);          (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
         if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {          %returnhash = %{$domdefs{'inststatustypes'}};
             &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");          @order = @{$domdefs{'inststatusorder'}};
             return (\%returnhash,\@order);  
         }  
         my ($hashitems,$orderitems) = split(/:/,$rep);   
         my @pairs=split(/\&/,$hashitems);  
         foreach my $item (@pairs) {  
             my ($key,$value)=split(/=/,$item,2);  
             $key = &unescape($key);  
             next if ($key =~ /^error: 2 /);  
             $returnhash{$key}=&thaw_unescape($value);  
         }  
         my @esc_order = split(/\&/,$orderitems);  
         foreach my $item (@esc_order) {  
             push(@order,&unescape($item));  
         }  
     } else {      } else {
         &logthis("get_dom failed - no primary domain server for $udom");          if (defined(&domain($udom,'primary'))) {
               my $uhome=&domain($udom,'primary');
               my $rep=&reply("inst_usertypes:$udom",$uhome);
               if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
                   &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");
                   return (\%returnhash,\@order);
               }
               my ($hashitems,$orderitems) = split(/:/,$rep); 
               my @pairs=split(/\&/,$hashitems);
               foreach my $item (@pairs) {
                   my ($key,$value)=split(/=/,$item,2);
                   $key = &unescape($key);
                   next if ($key =~ /^error: 2 /);
                   $returnhash{$key}=&thaw_unescape($value);
               }
               my @esc_order = split(/\&/,$orderitems);
               foreach my $item (@esc_order) {
                   push(@order,&unescape($item));
               }
           } else {
               &logthis("get_dom failed - no primary domain server for $udom");
           }
     }      }
     return (\%returnhash,\@order);      return (\%returnhash,\@order);
 }  }
Line 1203  sub inst_userrules { Line 1286  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 1217  sub get_domain_defaults { Line 1299  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') {
               $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 1551  sub purge_remembered { Line 1659  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 @answer=split(/\&/,
                 &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),                  &reply('get:'.$udom.':'.$unam.':environment:'.$items,
                       &homeserver($unam,$udom)));                        &homeserver($unam,$udom)));
     my $i;      my $i;
     for ($i=0;$i<=$#what;$i++) {      for ($i=0;$i<=$#what;$i++) {
Line 1750  sub ssi_body { Line 1863  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 1796  sub ssi { Line 1911  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 1973  sub clean_filename { Line 2088  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 2032  sub userfileupload { Line 2173  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 2073  sub finishuserfileupload { Line 2217  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 2087  sub finishuserfileupload { Line 2232  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 2100  sub finishuserfileupload { Line 2246  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 $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles,
Line 2121  sub finishuserfileupload { Line 2272  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 2253  sub add_filetype { Line 2404  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 2410  sub flushcourselogs { Line 2561  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 2470  sub courseacclog { Line 2621  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 2560  sub courserolelog { Line 2716  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 2569  sub get_course_adv_roles { Line 2728  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 2581  sub get_course_adv_roles { Line 2741  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 2599  sub get_course_adv_roles { Line 2773  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 2634  sub get_my_roles { Line 2808  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 2682  sub get_my_roles { Line 2857  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 3254  sub tmpreset { Line 3452  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 3690  sub set_userprivs { Line 3888  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 3733  sub set_userprivs { Line 3931  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 && $$tstart>$refresh) {
                       if ($$tstart<$now) {
                           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 3768  sub del { Line 4061  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 4332  sub is_portfolio_file { Line 4625  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,
                    );
       } 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);
           $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;
   }
   
 # ---------------------------------------------- Custom access rule evaluation  # ---------------------------------------------- Custom access rule evaluation
   
Line 4647  sub allowed { Line 5082  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 4938  sub fetch_enrollment_query { Line 5373  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 5265  sub auto_instcode_defaults { Line 5700  sub auto_instcode_defaults {
     }      }
   
     return $response;      return $response;
 }   }
   
   sub auto_possible_instcodes {
       my ($domain,$codetitles,$cat_titles,$cat_order) = @_;
       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,$cat_title,$cat_order) = split(':',$response);
           @{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr));  
           foreach my $item (split('&',$cat_title)) {   
               my ($name,$value)=split('&',$item);
               $cat_titles->{&unescape($name)}=&unescape($value);
           }
           foreach my $item (split('&',$cat_order)) {
               my ($name,$value)=split('&',$item);
               $cat_order->{&unescape($name)}=&unescape($value);
           }
           return 'ok';
       }
       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 5418  sub devalidate_getgroups_cache { Line 5886  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'})) {      if (defined($cid) && ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '')) {
         return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short.          unless ($forcedefault) {
                                           '.plaintext'});              my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'}; 
               &Apache::lonlocal::mt_escape(\$roletext);
               return &Apache::lonlocal::mt($roletext);
           }
     }      }
     my %rolenames = (      my %rolenames = (
                       Course => 'std',                        Course => 'std',
Line 5648  sub modifyuser { Line 6119  sub modifyuser {
        if ($email=~/\@/) { $names{'permanentemail'} = $email; }         if ($email=~/\@/) { $names{'permanentemail'} = $email; }
     }      }
     if ($uid) { $names{'id'}  = $uid; }      if ($uid) { $names{'id'}  = $uid; }
     if (defined($inststatus)) { $names{'inststatus'} = $inststatus; }       if (defined($inststatus)) {
           $names{'inststatus'} = '';
           my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom);
           if (ref($usertypes) eq 'HASH') {
               my @okstatuses; 
               foreach my $item (split(/:/,$inststatus)) {
                   if (defined($usertypes->{$item})) {
                       push(@okstatuses,$item);  
                   }
               }
               if (@okstatuses) {
                   $names{'inststatus'} = join(':', map { &escape($_); } @okstatuses);
               }
           }
       }
     my $reply = &put('environment', \%names, $udom,$uname);      my $reply = &put('environment', \%names, $udom,$uname);
     if ($reply ne 'ok') { return 'error: '.$reply; }      if ($reply ne 'ok') { return 'error: '.$reply; }
     my $sqlresult = &update_allusers_table($uname,$udom,\%names);      my $sqlresult = &update_allusers_table($uname,$udom,\%names);
Line 5670  sub modifyuser { Line 6155  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 5679  sub modifystudent { Line 6164  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 7429  sub symblist { Line 7914  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 8136  sub repcopy_userfile { Line 8621  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 8151  sub repcopy_userfile { Line 8639  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 8159  sub tokenwrapper { Line 8647  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 8174  sub tokenwrapper { Line 8665  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 8256  sub filelocation { Line 8750  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 8452  sub get_dns { Line 8946  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 8524  sub get_dns { Line 9023  sub get_dns {
  }   }
  return $domain{$name}{$what};   return $domain{$name}{$what};
     }      }
   
       sub domain_info {
           &load_domain_tab() if (!$loaded);
           return %domain;
       }
   
 }  }
   
   
Line 8601  sub get_dns { Line 9106  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 8742  sub get_dns { Line 9252  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 9023  in the user's environment.db and in %env Line 9558  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 9122  and course level Line 9659  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 Group.
   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 9633  dirlist($uri) : return directory list ba Line 10175  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.970  
changed lines
  Added in v.1.1004

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