[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.842 and 1.871

version 1.842, 2007/03/03 01:54:13 version 1.871, 2007/04/20 21:48:09
Line 31  package Apache::lonnet; Line 31  package Apache::lonnet;
   
 use strict;  use strict;
 use LWP::UserAgent();  use LWP::UserAgent();
 use HTTP::Headers;  
 use HTTP::Date;  use HTTP::Date;
 # use Date::Parse;  # use Date::Parse;
 use vars   use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
 qw(%perlvar %badServerCache %iphost %spareid %hostdom               $_64bit %env);
    %libserv %pr %prp $memcache %packagetab   
    %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount   my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf      %userrolehash, $processmarker, $dumpcount, %coursedombuf,
    %domaindescription %domain_auth_def %domain_auth_arg_def       %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,
    %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary      %courseownerbuf, %coursetypebuf);
    $tmpdir $_64bit %env);  
   
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
 use HTML::LCParser;  use HTML::LCParser;
 use HTML::Parser;  
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
 use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);  use Storable qw(thaw nfreeze);
 use Time::HiRes qw( gettimeofday tv_interval );  use Time::HiRes qw( gettimeofday tv_interval );
 use Cache::Memcached;  use Cache::Memcached;
 use Digest::MD5;  use Digest::MD5;
Line 146  sub logperm { Line 143  sub logperm {
     return 1;      return 1;
 }  }
   
   sub create_connection {
       my ($hostname,$lonid) = @_;
       my $client=IO::Socket::UNIX->new(Peer    => $perlvar{'lonSockCreate'},
        Type    => SOCK_STREAM,
        Timeout => 10);
       return 0 if (!$client);
       print $client (join(':',$hostname,$lonid,&machine_ids($lonid))."\n");
       my $result = <$client>;
       chomp($result);
       return 1 if ($result eq 'done');
       return 0;
   }
   
   
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
 sub subreply {  sub subreply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
Line 170  sub subreply { Line 181  sub subreply {
  $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",   $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
       Type    => SOCK_STREAM,        Type    => SOCK_STREAM,
       Timeout => 10);        Timeout => 10);
  if($client) {   if ($client) {
     last; # Connected!      last; # Connected!
    } else {
       &create_connection(&hostname($server),$server);
  }   }
  sleep(1); # Try again later if failed connection.          sleep(1); # Try again later if failed connection.
     }      }
     my $answer;      my $answer;
     if ($client) {      if ($client) {
Line 720  sub idput { Line 733  sub idput {
 # ------------------------------------------- get items from domain db files     # ------------------------------------------- get items from domain db files   
   
 sub get_dom {  sub get_dom {
     my ($namespace,$storearr,$udom)=@_;      my ($namespace,$storearr,$udom,$uhome)=@_;
     my $items='';      my $items='';
     foreach my $item (@$storearr) {      foreach my $item (@$storearr) {
         $items.=&escape($item).'&';          $items.=&escape($item).'&';
     }      }
     $items=~s/\&$//;      $items=~s/\&$//;
     if (!$udom) { $udom=$env{'user.domain'}; }      if (!$udom) {
     if (exists($domain_primary{$udom})) {          $udom=$env{'user.domain'};
         my $uhome=$domain_primary{$udom};          if (defined(&domain($udom,'primary'))) {
               $uhome=&domain($udom,'primary');
           } else {
               $uhome eq '';
           }
       } else {
           if (!$uhome) {
               if (defined(&domain($udom,'primary'))) {
                   $uhome=&domain($udom,'primary');
               }
           }
       }
       if ($udom && $uhome && ($uhome ne 'no_host')) {
         my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);          my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
           my %returnhash;
           if ($rep =~ /^error: 2 /) {
               return %returnhash;
           }
         my @pairs=split(/\&/,$rep);          my @pairs=split(/\&/,$rep);
         if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {          if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
             return @pairs;              return @pairs;
Line 742  sub get_dom { Line 771  sub get_dom {
         }          }
         return %returnhash;          return %returnhash;
     } else {      } else {
         &logthis("get_dom failed - no primary domain server for $udom");          &logthis("get_dom failed - no homeserver and/or domain");
     }      }
 }  }
   
 # -------------------------------------------- put items in domain db files   # -------------------------------------------- put items in domain db files 
   
 sub put_dom {  sub put_dom {
     my ($namespace,$storehash,$udom)=@_;      my ($namespace,$storehash,$udom,$uhome)=@_;
     if (!$udom) { $udom=$env{'user.domain'}; }      if (!$udom) {
     if (exists($domain_primary{$udom})) {          $udom=$env{'user.domain'};
         my $uhome=$domain_primary{$udom};          if (defined(&domain($udom,'primary'))) {
               $uhome=&domain($udom,'primary');
           } else {
               $uhome eq '';
           }
       } else {
           if (!$uhome) {
               if (defined(&domain($udom,'primary'))) {
                   $uhome=&domain($udom,'primary');
               }
           }
       } 
       if ($udom && $uhome && ($uhome ne 'no_host')) {
         my $items='';          my $items='';
         foreach my $item (keys(%$storehash)) {          foreach my $item (keys(%$storehash)) {
             $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';              $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
Line 760  sub put_dom { Line 801  sub put_dom {
         $items=~s/\&$//;          $items=~s/\&$//;
         return &reply("putdom:$udom:$namespace:$items",$uhome);          return &reply("putdom:$udom:$namespace:$items",$uhome);
     } else {      } else {
         &logthis("put_dom failed - no primary domain server for $udom");          &logthis("put_dom failed - no homeserver and/or domain");
     }      }
 }  }
   
 sub retrieve_inst_usertypes {  sub retrieve_inst_usertypes {
     my ($udom) = @_;      my ($udom) = @_;
     my (%returnhash,@order);      my (%returnhash,@order);
     if (exists($domain_primary{$udom})) {      if (defined(&domain($udom,'primary'))) {
         my $uhome=$domain_primary{$udom};          my $uhome=&domain($udom,'primary');
         my $rep=&reply("inst_usertypes:$udom",$uhome);          my $rep=&reply("inst_usertypes:$udom",$uhome);
         my ($hashitems,$orderitems) = split(/:/,$rep);           my ($hashitems,$orderitems) = split(/:/,$rep); 
         my @pairs=split(/\&/,$hashitems);          my @pairs=split(/\&/,$hashitems);
Line 788  sub retrieve_inst_usertypes { Line 829  sub retrieve_inst_usertypes {
     return (\%returnhash,\@order);      return (\%returnhash,\@order);
 }  }
   
   sub is_domainimage {
       my ($url) = @_;
       if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+-) {
           if (&domain($1) ne '') {
               return '1';
           }
       }
       return;
   }
   
 # --------------------------------------------------- Assign a key to a student  # --------------------------------------------------- Assign a key to a student
   
 sub assign_access_key {  sub assign_access_key {
Line 1012  my %remembered; Line 1063  my %remembered;
 my %accessed;  my %accessed;
 my $kicks=0;  my $kicks=0;
 my $hits=0;  my $hits=0;
   sub make_key {
       my ($name,$id) = @_;
       if (length($id) > 200) { $id=length($id).':'.&Digest::MD5::md5_hex($id); }
       return &escape($name.':'.$id);
   }
   
 sub devalidate_cache_new {  sub devalidate_cache_new {
     my ($name,$id,$debug) = @_;      my ($name,$id,$debug) = @_;
     if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }      if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
     $id=&escape($name.':'.$id);      $id=&make_key($name,$id);
     $memcache->delete($id);      $memcache->delete($id);
     delete($remembered{$id});      delete($remembered{$id});
     delete($accessed{$id});      delete($accessed{$id});
Line 1023  sub devalidate_cache_new { Line 1080  sub devalidate_cache_new {
   
 sub is_cached_new {  sub is_cached_new {
     my ($name,$id,$debug) = @_;      my ($name,$id,$debug) = @_;
     $id=&escape($name.':'.$id);      $id=&make_key($name,$id);
     if (exists($remembered{$id})) {      if (exists($remembered{$id})) {
  if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }   if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
  $accessed{$id}=[&gettimeofday()];   $accessed{$id}=[&gettimeofday()];
Line 1046  sub is_cached_new { Line 1103  sub is_cached_new {
   
 sub do_cache_new {  sub do_cache_new {
     my ($name,$id,$value,$time,$debug) = @_;      my ($name,$id,$value,$time,$debug) = @_;
     $id=&escape($name.':'.$id);      $id=&make_key($name,$id);
     my $setvalue=$value;      my $setvalue=$value;
     if (!defined($setvalue)) {      if (!defined($setvalue)) {
  $setvalue='__undef__';   $setvalue='__undef__';
Line 1496  sub clean_filename { Line 1553  sub clean_filename {
 #        $coursedoc - if true up to the current course  #        $coursedoc - if true up to the current course
 #                     if false  #                     if false
 #        $subdir - directory in userfile to store the file into  #        $subdir - directory in userfile to store the file into
 #        $parser, $allfiles, $codebase - unknown  #        $parser - instruction to parse file for objects ($parser = parse)    
 #  #        $allfiles - reference to hash for embedded objects
   #        $codebase - reference to hash for codebase of java objects
   #        $desuname - username for permanent storage of uploaded file
   #        $dsetudom - domain for permanaent storage of uploaded file
   #        $thumbwidth - width (pixels) of thumbnail to make for uploaded image 
   #        $thumbheight - height (pixels) of thumbnail to make for uploaded image
   # 
 # output: url of file in userspace, or error: <message>   # output: url of file in userspace, or error: <message> 
 #             or /adm/notfound.html if failure to upload occurse  #             or /adm/notfound.html if failure to upload occurse
   
   
 sub userfileupload {  sub userfileupload {
     my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_;      my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,
           $destudom,$thumbwidth,$thumbheight)=@_;
     if (!defined($subdir)) { $subdir='unknown'; }      if (!defined($subdir)) { $subdir='unknown'; }
     my $fname=$env{'form.'.$formname.'.filename'};      my $fname=$env{'form.'.$formname.'.filename'};
     $fname=&clean_filename($fname);      $fname=&clean_filename($fname);
Line 1550  sub userfileupload { Line 1614  sub userfileupload {
         if ($env{'form.folder'} =~ m/^(default|supplemental)/) {          if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
             return &finishuserfileupload($docuname,$docudom,              return &finishuserfileupload($docuname,$docudom,
  $formname,$fname,$parser,$allfiles,   $formname,$fname,$parser,$allfiles,
  $codebase);   $codebase,$thumbwidth,$thumbheight);
         } else {          } else {
             $fname=$env{'form.folder'}.'/'.$fname;              $fname=$env{'form.folder'}.'/'.$fname;
             return &process_coursefile('uploaddoc',$docuname,$docudom,              return &process_coursefile('uploaddoc',$docuname,$docudom,
Line 1560  sub userfileupload { Line 1624  sub userfileupload {
     } elsif (defined($destuname)) {      } elsif (defined($destuname)) {
         my $docuname=$destuname;          my $docuname=$destuname;
         my $docudom=$destudom;          my $docudom=$destudom;
  return &finishuserfileupload($docuname,$docudom,$formname,   return &finishuserfileupload($docuname,$docudom,$formname,$fname,
      $fname,$parser,$allfiles,$codebase);       $parser,$allfiles,$codebase,
                                        $thumbwidth,$thumbheight);
                   
     } else {      } else {
         my $docuname=$env{'user.name'};          my $docuname=$env{'user.name'};
Line 1570  sub userfileupload { Line 1635  sub userfileupload {
             $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};              $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
             $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};              $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
         }          }
  return &finishuserfileupload($docuname,$docudom,$formname,   return &finishuserfileupload($docuname,$docudom,$formname,$fname,
      $fname,$parser,$allfiles,$codebase);       $parser,$allfiles,$codebase,
                                        $thumbwidth,$thumbheight);
     }      }
 }  }
   
 sub finishuserfileupload {  sub finishuserfileupload {
     my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_;      my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase,
           $thumbwidth,$thumbheight) = @_;
     my $path=$docudom.'/'.$docuname.'/';      my $path=$docudom.'/'.$docuname.'/';
     my $filepath=$perlvar{'lonDocRoot'};      my $filepath=$perlvar{'lonDocRoot'};
     my ($fnamepath,$file);      my ($fnamepath,$file,$fetchthumb);
     $file=$fname;      $file=$fname;
     if ($fname=~m|/|) {      if ($fname=~m|/|) {
         ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|);          ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|);
Line 1615  sub finishuserfileupload { Line 1682  sub finishuserfileupload {
      ' for embedded media: '.$parse_result);        ' for embedded media: '.$parse_result); 
         }          }
     }      }
       if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
           my $input = $filepath.'/'.$file;
           my $output = $filepath.'/'.'tn-'.$file;
           my $thumbsize = $thumbwidth.'x'.$thumbheight;
           system("convert -sample $thumbsize $input $output");
           if (-e $filepath.'/'.'tn-'.$file) {
               $fetchthumb  = 1; 
           }
       }
    
 # 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) {
               my $thumbresult= &reply('fetchuserfile:'.$path.'tn-'.$file,$docuhome);
               if ($thumbresult ne 'ok') {
                   &logthis('Failed to transfer '.$path.'tn-'.$file.' to host '.
                            $docuhome.': '.$thumbresult);
               }
           }
 #  #
 # Return the URL to it  # Return the URL to it
         return '/uploaded/'.$path.$file;          return '/uploaded/'.$path.$file;
Line 1627  sub finishuserfileupload { Line 1711  sub finishuserfileupload {
         &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.          &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
  ': '.$fetchresult);   ': '.$fetchresult);
         return '/adm/notfound.html';          return '/adm/notfound.html';
     }          }
 }  }
   
 sub extract_embedded_items {  sub extract_embedded_items {
Line 1842  sub flushcourselogs { Line 1926  sub flushcourselogs {
 # Is used in pickcourse  # Is used in pickcourse
 #  #
     foreach my $crs_home (keys(%courseidbuffer)) {      foreach my $crs_home (keys(%courseidbuffer)) {
         &courseidput($hostdom{$crs_home},$courseidbuffer{$crs_home},          &courseidput(&host_domain($crs_home),$courseidbuffer{$crs_home},
      $crs_home);       $crs_home);
     }      }
 #  #
Line 2049  sub get_course_adv_roles { Line 2133  sub get_course_adv_roles {
 }  }
   
 sub get_my_roles {  sub get_my_roles {
     my ($uname,$udom,$types,$roles,$roledoms)=@_;      my ($uname,$udom,$context,$types,$roles,$roledoms)=@_;
     unless (defined($uname)) { $uname=$env{'user.name'}; }      unless (defined($uname)) { $uname=$env{'user.name'}; }
     unless (defined($udom)) { $udom=$env{'user.domain'}; }      unless (defined($udom)) { $udom=$env{'user.domain'}; }
     my %dumphash=      my %dumphash;
       if ($context eq 'userroles') { 
           %dumphash = &dump('roles',$udom,$uname);
       } else {
           %dumphash=
             &dump('nohist_userroles',$udom,$uname);              &dump('nohist_userroles',$udom,$uname);
       }
     my %returnhash=();      my %returnhash=();
     my $now=time;      my $now=time;
     foreach my $entry (keys(%dumphash)) {      foreach my $entry (keys(%dumphash)) {
  my ($tend,$tstart)=split(/\:/,$dumphash{$entry});          my ($role,$tend,$tstart);
           if ($context eq 'userroles') {
       ($role,$tend,$tstart)=split(/_/,$dumphash{$entry});
           } else {
               ($tend,$tstart)=split(/\:/,$dumphash{$entry});
           }
         if (($tstart) && ($tstart<0)) { next; }          if (($tstart) && ($tstart<0)) { next; }
         my $status = 'active';          my $status = 'active';
         if (($tend) && ($tend<$now)) {          if (($tend) && ($tend<$now)) {
Line 2075  sub get_my_roles { Line 2169  sub get_my_roles {
                 next;                  next;
             }              }
         }          }
         my ($role,$username,$domain,$section)=split(/\:/,$entry);          my ($rolecode,$username,$domain,$section,$area);
           if ($context eq 'userroles') {
               ($area,$rolecode) = split(/_/,$entry);
               (undef,$domain,$username,$section) = split(/\//,$area);
           } else {
               ($role,$username,$domain,$section) = split(/\:/,$entry);
           }
         if (ref($roledoms) eq 'ARRAY') {          if (ref($roledoms) eq 'ARRAY') {
             if (!grep(/^\Q$domain\E$/,@{$roledoms})) {              if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
                 next;                  next;
Line 2085  sub get_my_roles { Line 2185  sub get_my_roles {
             if (!grep(/^\Q$role\E$/,@{$roles})) {              if (!grep(/^\Q$role\E$/,@{$roles})) {
                 next;                  next;
             }              }
         }           }
  $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;   $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
     }      }
     return %returnhash;      return %returnhash;
Line 2097  sub get_my_roles { Line 2197  sub get_my_roles {
   
 sub postannounce {  sub postannounce {
     my ($server,$text)=@_;      my ($server,$text)=@_;
     unless (&allowed('psa',$hostdom{$server})) { return 'refused'; }      unless (&allowed('psa',&host_domain($server))) { return 'refused'; }
     unless ($text=~/\w/) { $text=''; }      unless ($text=~/\w/) { $text=''; }
     return &reply('setannounce:'.&escape($text),$server);      return &reply('setannounce:'.&escape($text),$server);
 }  }
Line 2133  sub courseiddump { Line 2233  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
     my %returnhash=();      my %returnhash=();
     unless ($domfilter) { $domfilter=''; }      unless ($domfilter) { $domfilter=''; }
     foreach my $tryserver (keys %libserv) {      my %libserv = &all_library();
         if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) {      foreach my $tryserver (keys(%libserv)) {
     if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {          if ( (  $hostidflag == 1 
           && grep(/^\Q$tryserver\E$/,@{$hostidref}) ) 
        || (!defined($hostidflag)) ) {
   
       if ($domfilter eq ''
    || (&host_domain($tryserver) eq $domfilter)) {
         foreach my $line (          foreach my $line (
                  split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.                   split(/\&/,&reply('courseiddump:'.&host_domain($tryserver).':'.
        $sincefilter.':'.&escape($descfilter).':'.         $sincefilter.':'.&escape($descfilter).':'.
                                &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),                                 &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),
                                $tryserver))) {                                 $tryserver))) {
Line 2165  sub dcmailput { Line 2270  sub dcmailput {
 sub dcmaildump {  sub dcmaildump {
     my ($dom,$startdate,$enddate,$senders) = @_;      my ($dom,$startdate,$enddate,$senders) = @_;
     my %returnhash=();      my %returnhash=();
     if (exists($domain_primary{$dom})) {  
       if (defined(&domain($dom,'primary'))) {
         my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.          my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
                                                          &escape($enddate).':';                                                           &escape($enddate).':';
  my @esc_senders=map { &escape($_)} @$senders;   my @esc_senders=map { &escape($_)} @$senders;
  $cmd.=&escape(join('&',@esc_senders));   $cmd.=&escape(join('&',@esc_senders));
  foreach my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {   foreach my $line (split(/\&/,&reply($cmd,&domain($dom,'primary')))) {
             my ($key,$value) = split(/\=/,$line,2);              my ($key,$value) = split(/\=/,$line,2);
             if (($key) && ($value)) {              if (($key) && ($value)) {
                 $returnhash{&unescape($key)} = &unescape($value);                  $returnhash{&unescape($key)} = &unescape($value);
Line 3504  sub get_portfolio_access { Line 3610  sub get_portfolio_access {
             }              }
             if (@users > 0) {              if (@users > 0) {
                 foreach my $userkey (@users) {                  foreach my $userkey (@users) {
                     if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {                      if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') {
                         return 'ok';                          foreach my $item (@{$access_hash->{$userkey}{'users'}}) {
                     }                              if (ref($item) eq 'HASH') {
                                   if (($item->{'uname'} eq $env{'user.name'}) &&
                                       ($item->{'udom'} eq $env{'user.domain'})) {
                                       return 'ok';
                                   }
                               }
                           }
                       } 
                 }                  }
             }              }
             my %roleshash;              my %roleshash;
Line 4170  sub definerole { Line 4283  sub definerole {
 sub metadata_query {  sub metadata_query {
     my ($query,$custom,$customshow,$server_array)=@_;      my ($query,$custom,$customshow,$server_array)=@_;
     my %rhash;      my %rhash;
       my %libserv = &all_library();
     my @server_list = (defined($server_array) ? @$server_array      my @server_list = (defined($server_array) ? @$server_array
                                               : keys(%libserv) );                                                : keys(%libserv) );
     for my $server (@server_list) {      for my $server (@server_list) {
Line 4322  sub courselog_query { Line 4436  sub courselog_query {
 }  }
   
 sub userlog_query {  sub userlog_query {
   #
   # possible filters:
   # action: log check role
   # start: timestamp
   # end: timestamp
   #
     my ($uname,$udom,%filters)=@_;      my ($uname,$udom,%filters)=@_;
     return &log_query($uname,$udom,'userlog',%filters);      return &log_query($uname,$udom,'userlog',%filters);
 }  }
Line 4811  sub modifyuser { Line 4931  sub modifyuser {
     if (($uhome eq 'no_host') &&       if (($uhome eq 'no_host') && 
  (($umode && $upass) || ($umode eq 'localauth'))) {   (($umode && $upass) || ($umode eq 'localauth'))) {
         my $unhome='';          my $unhome='';
         if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {           if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { 
             $unhome = $desiredhome;              $unhome = $desiredhome;
  } elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) {   } elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) {
     $unhome=$env{'course.'.$env{'request.course.id'}.'.home'};      $unhome=$env{'course.'.$env{'request.course.id'}.'.home'};
Line 5038  sub createcourse { Line 5158  sub createcourse {
    }     }
 # ------------------------------------------------ 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 (! exists($libserv{$course_server})) {      if (! &is_library($course_server)) {
         return 'error:bad server name '.$course_server;          return 'error:bad server name '.$course_server;
     }      }
 # ------------------------------------------------------------- Make the course  # ------------------------------------------------------------- Make the course
Line 5174  sub save_selected_files { Line 5294  sub save_selected_files {
     my ($user, $path, @files) = @_;      my ($user, $path, @files) = @_;
     my $filename = $user."savedfiles";      my $filename = $user."savedfiles";
     my @other_files = &files_not_in_path($user, $path);      my @other_files = &files_not_in_path($user, $path);
     open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);      open (OUT, '>'.$tmpdir.$filename);
     foreach my $file (@files) {      foreach my $file (@files) {
         print (OUT $env{'form.currentpath'}.$file."\n");          print (OUT $env{'form.currentpath'}.$file."\n");
     }      }
Line 6171  sub packages_tab_default { Line 6291  sub packages_tab_default {
     $do_default=1;      $do_default=1;
  } elsif ($pack_type eq 'extension') {   } elsif ($pack_type eq 'extension') {
     push(@extension,[$package,$pack_type,$pack_part]);      push(@extension,[$package,$pack_type,$pack_part]);
  } else {   } elsif ($pack_part eq $part) {
       # only look at packages defaults for packages that this id is
     push(@specifics,[$package,$pack_type,$pack_part]);      push(@specifics,[$package,$pack_type,$pack_part]);
  }   }
     }      }
Line 6889  sub getCODE { Line 7010  sub getCODE {
   
 sub rndseed {  sub rndseed {
     my ($symb,$courseid,$domain,$username)=@_;      my ($symb,$courseid,$domain,$username)=@_;
   
     my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();      my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
     if (!$symb) {      if (!$symb) {
  unless ($symb=$wsymb) { return time; }   unless ($symb=$wsymb) { return time; }
Line 7398  sub hreflocation { Line 7518  sub hreflocation {
 }  }
   
 sub current_machine_domains {  sub current_machine_domains {
     my $hostname=&hostname($perlvar{'lonHostID'});      return &machine_domains(&hostname($perlvar{'lonHostID'}));
   }
   
   sub machine_domains {
       my ($hostname) = @_;
     my @domains;      my @domains;
     my %hostname = &all_hostnames();      my %hostname = &all_hostnames();
     while( my($id, $name) = each(%hostname)) {      while( my($id, $name) = each(%hostname)) {
 # &logthis("-$id-$name-$hostname-");  # &logthis("-$id-$name-$hostname-");
  if ($hostname eq $name) {   if ($hostname eq $name) {
     push(@domains,$hostdom{$id});      push(@domains,&host_domain($id));
  }   }
     }      }
     return @domains;      return @domains;
 }  }
   
 sub current_machine_ids {  sub current_machine_ids {
     my $hostname=&hostname($perlvar{'lonHostID'});      return &machine_ids(&hostname($perlvar{'lonHostID'}));
   }
   
   sub machine_ids {
       my ($hostname) = @_;
       $hostname ||= &hostname($perlvar{'lonHostID'});
     my @ids;      my @ids;
     my %hostname = &all_hostnames();      my %hostname = &all_hostnames();
     while( my($id, $name) = each(%hostname)) {      while( my($id, $name) = each(%hostname)) {
Line 7533  sub correct_line_ends { Line 7662  sub correct_line_ends {
 sub goodbye {  sub goodbye {
    &logthis("Starting Shut down");     &logthis("Starting Shut down");
 #not converted to using infrastruture and probably shouldn't be  #not converted to using infrastruture and probably shouldn't be
    &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache))));     &logthis(sprintf("%-20s is %s",'%badServerCache',length(&nfreeze(\%badServerCache))));
 #converted  #converted
 #   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));  #   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
    &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));     &logthis(sprintf("%-20s is %s",'%homecache',length(&nfreeze(\%homecache))));
 #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));  #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&nfreeze(\%titlecache))));
 #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));  #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&nfreeze(\%courseresdatacache))));
 #1.1 only  #1.1 only
 #   &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache))));  #   &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&nfreeze(\%userresdatacache))));
 #   &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache))));  #   &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&nfreeze(\%getsectioncache))));
 #   &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache))));  #   &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&nfreeze(\%courseresversioncache))));
 #   &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache))));  #   &logthis(sprintf("%-20s is %s",'%resversioncache',length(&nfreeze(\%resversioncache))));
    &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));     &logthis(sprintf("%-20s is %s",'%remembered',length(&nfreeze(\%remembered))));
    &logthis(sprintf("%-20s is %s",'kicks',$kicks));     &logthis(sprintf("%-20s is %s",'kicks',$kicks));
    &logthis(sprintf("%-20s is %s",'hits',$hits));     &logthis(sprintf("%-20s is %s",'hits',$hits));
    &flushcourselogs();     &flushcourselogs();
    &logthis("Shutting down");     &logthis("Shutting down");
 }  }
   
 BEGIN {  sub get_dns {
 # ----------------------------------- Read loncapa.conf and loncapa_apache.conf      my ($url,$func,$ignore_cache) = @_;
     unless ($readit) {      if (!$ignore_cache) {
 {   my ($content,$cached)=
     my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');      &Apache::lonnet::is_cached_new('dns',$url);
     %perlvar = (%perlvar,%{$configvars});   if ($cached) {
 }      &$func($content);
       return;
    }
       }
   
       my %alldns;
       open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
       foreach my $dns (<$config>) {
    next if ($dns !~ /^\^(\S*)/x);
    $alldns{$1} = 1;
       }
       while (%alldns) {
    my ($dns) = keys(%alldns);
    delete($alldns{$dns});
    my $ua=new LWP::UserAgent;
    my $request=new HTTP::Request('GET',"http://$dns$url");
    my $response=$ua->request($request);
    next if ($response->is_error());
    my @content = split("\n",$response->content);
    &Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60);
    &$func(\@content);
    return;
       }
       close($config);
       my $which = (split('/',$url))[3];
       &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
       open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");
       my @content = <$config>;
       &$func(\@content);
       return;
   }
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
 {  {
     %domaindescription = ();      my $loaded;
     %domain_auth_def = ();      my %domain;
     %domain_auth_arg_def = ();  
     my $fh;      sub parse_domain_tab {
     if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {   my ($lines) = @_;
  while (my $line = <$fh>) {   foreach my $line (@$lines) {
            next if ($line =~ /^(\#|\s*$)/);      next if ($line =~ /^(\#|\s*$ )/x);
 #           next if /^\#/;  
            chomp $line;      chomp($line);
            my ($domain, $domain_description, $def_auth, $def_auth_arg,      my ($name,@elements) = split(/:/,$line,9);
        $def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9);      my %this_domain;
    $domain_auth_def{$domain}=$def_auth;      foreach my $field ('description', 'auth_def', 'auth_arg_def',
            $domain_auth_arg_def{$domain}=$def_auth_arg;         'lang_def', 'city', 'longi', 'lati',
    $domaindescription{$domain}=$domain_description;         'primary') {
    $domain_lang_def{$domain}=$def_lang;   $this_domain{$field} = shift(@elements);
    $domain_city{$domain}=$city;      }
    $domain_longi{$domain}=$longi;      $domain{$name} = \%this_domain;
    $domain_lati{$domain}=$lati;   }
            $domain_primary{$domain}=$primary;      }
   
       sub reset_domain_info {
    undef($loaded);
    undef(%domain);
       }
   
       sub load_domain_tab {
    my ($ignore_cache) = @_;
    &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache);
    my $fh;
    if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {
       my @lines = <$fh>;
       &parse_domain_tab(\@lines);
    }
    close($fh);
    $loaded = 1;
       }
   
       sub domain {
    &load_domain_tab() if (!$loaded);
   
  #         &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");   my ($name,$what) = @_;
 #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );   return if ( !exists($domain{$name}) );
   
    if (!$what) {
       return $domain{$name}{'description'};
  }   }
    return $domain{$name}{$what};
     }      }
     close ($fh);  
 }  }
   
   
 # ------------------------------------------------------------- Read hosts file  # ------------------------------------------------------------- Read hosts file
 {  {
     my %hostname;      my %hostname;
     open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");      my %hostdom;
       my %libserv;
     while (my $configline=<$config>) {      my $loaded;
        next if ($configline =~ /^(\#|\s*$)/);  
        chomp($configline);      sub parse_hosts_tab {
        my ($id,$domain,$role,$name)=split(/:/,$configline);   my ($file) = @_;
        $name=~s/\s//g;   foreach my $configline (@$file) {
        if ($id && $domain && $role && $name) {      next if ($configline =~ /^(\#|\s*$ )/x);
  $hostname{$id}=$name;      next if ($configline =~ /^\^/);
  $hostdom{$id}=$domain;      chomp($configline);
  if ($role eq 'library') { $libserv{$id}=$name; }      my ($id,$domain,$role,$name)=split(/:/,$configline);
        }      $name=~s/\s//g;
       if ($id && $domain && $role && $name) {
    $hostname{$id}=$name;
    $hostdom{$id}=$domain;
    if ($role eq 'library') { $libserv{$id}=$name; }
       }
    }
       }
       
       sub reset_hosts_info {
    &reset_domain_info();
    &reset_hosts_ip_info();
    undef(%hostname);
    undef(%hostdom);
    undef(%libserv);
    undef($loaded);
       }
   
       sub load_hosts_tab {
    my ($ignore_cache) = @_;
    &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache);
    open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
    my @config = <$config>;
    &parse_hosts_tab(\@config);
    close($config);
    $loaded=1;
     }      }
     close($config);  
     # FIXME: dev server don't want this, production servers _do_ want this  
     #&get_iphost();  
   
     sub hostname {      sub hostname {
    &load_hosts_tab() if (!$loaded);
   
  my ($lonid) = @_;   my ($lonid) = @_;
  return $hostname{$lonid};   return $hostname{$lonid};
     }      }
   
     sub all_hostnames {      sub all_hostnames {
    &load_hosts_tab() if (!$loaded);
   
  return %hostname;   return %hostname;
     }      }
   
       sub is_library {
    &load_hosts_tab() if (!$loaded);
   
    return exists($libserv{$_[0]});
       }
   
       sub all_library {
    &load_hosts_tab() if (!$loaded);
   
    return %libserv;
       }
   
     sub get_servers {      sub get_servers {
    &load_hosts_tab() if (!$loaded);
   
  my ($domain,$type) = @_;   my ($domain,$type) = @_;
  my %possible_hosts = ($type eq 'library') ? %libserv   my %possible_hosts = ($type eq 'library') ? %libserv
                                           : %hostname;                                            : %hostname;
  my %result;   my %result;
  if (ref($domain) eq 'ARRAY') {   if (ref($domain) eq 'ARRAY') {
     while ( my ($host,$hostname) = each(%possible_hosts)) {      while ( my ($host,$hostname) = each(%possible_hosts)) {
  if (grep(/\Q$hostdom{$host}\E/,@$domain)) {   if (grep(/^\Q$hostdom{$host}\E$/,@$domain)) {
     $result{$host} = $hostname;      $result{$host} = $hostname;
  }   }
     }      }
Line 7636  BEGIN { Line 7859  BEGIN {
  }   }
  return %result;   return %result;
     }      }
   
       sub host_domain {
    &load_hosts_tab() if (!$loaded);
   
    my ($lonid) = @_;
    return $hostdom{$lonid};
       }
   
     sub all_domains {      sub all_domains {
    &load_hosts_tab() if (!$loaded);
   
  my %seen;   my %seen;
  my @uniq = grep(!$seen{$_}++, values(%hostdom));   my @uniq = grep(!$seen{$_}++, values(%hostdom));
  return @uniq;   return @uniq;
     }      }
 }  }
   
 sub get_hosts_from_ip {  { 
     my ($ip) = @_;      my %iphost;
     my %iphosts = &get_iphost();      my %name_to_ip;
     if (ref($iphosts{$ip})) {      my %lonid_to_ip;
  return @{$iphosts{$ip}};  
       my %valid_ip;
       sub valid_ip {
    my ($ip) = @_;
    if (exists($iphost{$ip}) || exists($valid_ip{$ip})) {
       return 1;
    }
    my $name = gethostbyip($ip);
    my $lonid = &hostname($name);
    if (defined($lonid)) {
       $valid_ip{$ip} = $lonid;
       return 1;
    }
    my %iphosts = &get_iphost();
    if (ref($iphost{$ip})) {
       return 1;
    }
     }      }
     return;  
 }  
   
 sub get_iphost {      sub get_hosts_from_ip {
     if (%iphost) { return %iphost; }   my ($ip) = @_;
     my %name_to_ip;   my %iphosts = &get_iphost();
     my %hostname = &all_hostnames();   if (ref($iphosts{$ip})) {
     foreach my $id (keys(%hostname)) {      return @{$iphosts{$ip}};
  my $name=$hostname{$id};   }
  my $ip;   return;
  if (!exists($name_to_ip{$name})) {      }
     $ip = gethostbyname($name);      
     if (!$ip || length($ip) ne 4) {      sub reset_hosts_ip_info {
  &logthis("Skipping host $id name $name no IP found");   undef(%iphost);
  next;   undef(%name_to_ip);
    undef(%lonid_to_ip);
       }
   
       sub get_host_ip {
    my ($lonid) = @_;
    if (exists($lonid_to_ip{$lonid})) {
       return $lonid_to_ip{$lonid};
    }
    my $name=&hostname($lonid);
       my $ip = gethostbyname($name);
    return if (!$ip || length($ip) ne 4);
    $ip=inet_ntoa($ip);
    $name_to_ip{$name}   = $ip;
    $lonid_to_ip{$lonid} = $ip;
    return $ip;
       }
       
       sub get_iphost {
    my ($ignore_cache) = @_;
    if (!$ignore_cache) {
       if (%iphost) {
    return %iphost;
     }      }
     $ip=inet_ntoa($ip);      my ($ip_info,$cached)=
     $name_to_ip{$name} = $ip;   &Apache::lonnet::is_cached_new('iphost','iphost');
  } else {      if ($cached) {
     $ip = $name_to_ip{$name};   %iphost      = %{$ip_info->[0]};
    %name_to_ip  = %{$ip_info->[1]};
    %lonid_to_ip = %{$ip_info->[2]};
    return %iphost;
       }
    }
    my %hostname = &all_hostnames();
    foreach my $id (keys(%hostname)) {
       my $name=&hostname($id);
       my $ip;
       if (!exists($name_to_ip{$name})) {
    $ip = gethostbyname($name);
    if (!$ip || length($ip) ne 4) {
       &logthis("Skipping host $id name $name no IP found");
       next;
    }
    $ip=inet_ntoa($ip);
    $name_to_ip{$name} = $ip;
       } else {
    $ip = $name_to_ip{$name};
       }
       $lonid_to_ip{$id} = $ip;
       push(@{$iphost{$ip}},$id);
  }   }
  push(@{$iphost{$ip}},$id);   &Apache::lonnet::do_cache_new('iphost','iphost',
         [\%iphost,\%name_to_ip,\%lonid_to_ip],
         24*60*60);
   
    return %iphost;
     }      }
     return %iphost;  
 }  }
   
   BEGIN {
   
   # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
       unless ($readit) {
   {
       my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
       %perlvar = (%perlvar,%{$configvars});
   }
   
   
 # ------------------------------------------------------ Read spare server file  # ------------------------------------------------------ Read spare server file
 {  {
     open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");      open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");
Line 8006  X<userenvironment()> Line 8310  X<userenvironment()>
 B<userenvironment($udom,$uname,@what)>: gets the values of the keys  B<userenvironment($udom,$uname,@what)>: gets the values of the keys
 passed in @what from the requested user's environment, returns a hash  passed in @what from the requested user's environment, returns a hash
   
   =item * 
   X<userlog_query()>
   B<userlog_query($uname,$udom,%filters)>: retrieves data from a user's
   activity.log file. %filters defines filters applied when parsing the
   log file. These can be start or end timestamps, or the type of action
   - log to look for Login or Logout events, check for Checkin or
   Checkout, role for role selection. The response is in the form
   timestamp1:hostid1:event1&timestamp2:hostid2:event2 where events are
   escaped strings of the action recorded in the activity.log file.
   
 =back  =back
   
 =head2 User Roles  =head2 User Roles
Line 8035  explanation of a user role term Line 8349  explanation of a user role term
   
 =item *  =item *
   
 get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are  get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) :
 optional.  Returns a hash of a user's roles, with keys set to  All arguments are optional. Returns a hash of a roles, either for
 colon-sparated $uname,$udom,and $role, and value set to  co-author/assistant author roles for a user's Construction Space
 colon-separated start and end times for the role. If no username and  (default), or if $context is 'user', roles for the user himself,
 domain are specified, will default to current user/domain. Types,  In the hash, keys are set to colon-sparated $uname,$udom,and $role,
 roles, and roledoms are references to arrays, of role statuses  and value is set to colon-separated start and end times for the role.
 (active, future or previous), roles (e.g., cc,in, st etc.) and domains  If no username and domain are specified, will default to current
 of the roles which can be used to restrict the list if roles  user/domain. Types, roles, and roledoms are references to arrays,
 reported. If no array ref is provided for types, will default to  of role statuses (active, future or previous), roles 
 return only active roles.  (e.g., cc,in, st etc.) and domains of the roles which can be used
   to restrict the list of roles reported. If no array ref is 
   provided for types, will default to return only active roles.
   
 =back  =back
   
Line 8469  critical subroutine Line 8785  critical subroutine
   
 =item *  =item *
   
 get_dom($namespace,$storearr,$udomain) : returns hash with keys from array  get_dom($namespace,$storearr,$udom,$uhome) : returns hash with keys from
 reference filled in from namespace found in domain level on primary domain server ($udomain is optional)  array reference filled in from namespace found in domain level on either
   specified domain server ($uhome) or primary domain server ($udom and $uhome are optional).
   
 =item *  =item *
   
 put_dom($namespace,$storehash,$udomain) :  stores hash in namespace at domain level on primary domain server ($udomain is optional)  put_dom($namespace,$storehash,$udom,$uhome) :  stores hash in namespace at 
   domain level either on specified domain server ($uhome) or primary domain 
   server ($udom and $uhome are optional)
   
 =back  =back
   
Removed from v.1.842  
changed lines
  Added in v.1.871

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