[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.853 and 1.862

version 1.853, 2007/03/28 20:28:31 version 1.862, 2007/04/04 00:07:07
Line 150  sub create_connection { Line 150  sub create_connection {
      Type    => SOCK_STREAM,       Type    => SOCK_STREAM,
      Timeout => 10);       Timeout => 10);
     return 0 if (!$client);      return 0 if (!$client);
     print $client ("$hostname:$lonid\n");      print $client (join(':',$hostname,$lonid,&machine_ids($lonid))."\n");
     my $result = <$client>;      my $result = <$client>;
     chomp($result);      chomp($result);
     return 1 if ($result eq 'done');      return 1 if ($result eq 'done');
Line 671  sub homeserver { Line 671  sub homeserver {
     return 'no_host';      return 'no_host';
 }  }
   
   # ---------------------- Get domain configuration for a domain
   sub get_domainconf {
       my ($udom) = @_;
       my $cachetime=1800;
       my ($result,$cached)=&is_cached_new('domainconfig',$udom);
       if (defined($cached)) { return %{$result}; }
   
       if ($udom eq '') {
           $udom = &Apache::loncommon::determinedomain();
       }
       my %domconfig = &get_dom('configuration',['login','rolecolors'],$udom);
       my %designhash;
       if (keys(%domconfig) > 0) {
           if (ref($domconfig{'login'}) eq 'HASH') {
               foreach my $key (keys(%{$domconfig{'login'}})) {
                   $designhash{$udom.'.login.'.$key}=$domconfig{'login'}{$key};
               }
           }
           if (ref($domconfig{'rolecolors'}) eq 'HASH') {
               foreach my $role (keys(%{$domconfig{'rolecolors'}})) {
                   if (ref($domconfig{'rolecolors'}{$role}) eq 'HASH') {
                       foreach my $item (keys(%{$domconfig{'rolecolors'}{$role}})) {
                           $designhash{$udom.'.'.$role.'.'.$item}=$domconfig{'rolecolors'}{$role}{$item};
                       }
                   }
               }
           }
       } else {
           my $designdir=$perlvar{'lonTabDir'}.'/lonDomColors';
           my $designfile =  $designdir.'/'.$udom.'.tab';
           if (-e $designfile) {
               if ( open (my $fh,"<$designfile") ) {
                   while (my $line = <$fh>) {
                       next if ($line =~ /^\#/);
                       chomp($line);
                       my ($key,$val)=(split(/\=/,$line));
                       if ($val) { $designhash{$udom.'.'.$key}=$val; }
                   }
                   close($fh);
               }
           }
           if (-e '/home/httpd/html/adm/lonDomLogos/'.$udom.'.gif') {
               $designhash{$udom.'.login.domlogo'} = 
                   &lonhttpdurl("/adm/lonDomLogos/$udom.gif"); 
           }
       }
       &do_cache_new('domainconfig',$udom,\%designhash,$cachetime);
       return %designhash;
   }
   
   sub devalidate_domconfig_cache {
       my ($udom)=@_;
       &devalidate_cache_new('domainconfig',$udom);
   }
   
 # ------------------------------------- Find the usernames behind a list of IDs  # ------------------------------------- Find the usernames behind a list of IDs
   
 sub idget {  sub idget {
Line 734  sub idput { Line 789  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 (defined(&domain($udom,'primary'))) {          $udom=$env{'user.domain'};
         my $uhome=&domain($udom,'primary');          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 @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) {
Line 756  sub get_dom { Line 823  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 (defined(&domain($udom,'primary'))) {          $udom=$env{'user.domain'};
         my $uhome=&domain($udom,'primary');          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 774  sub put_dom { Line 853  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");
     }      }
 }  }
   
Line 1516  sub clean_filename { Line 1595  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 1570  sub userfileupload { Line 1656  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 1580  sub userfileupload { Line 1666  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 1590  sub userfileupload { Line 1677  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 1635  sub finishuserfileupload { Line 1724  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 1647  sub finishuserfileupload { Line 1753  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 2069  sub get_course_adv_roles { Line 2175  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)) {
Line 4349  sub courselog_query { Line 4460  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 6917  sub getCODE { Line 7034  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 7588  sub goodbye { Line 7704  sub goodbye {
    &logthis("Shutting down");     &logthis("Shutting down");
 }  }
   
 BEGIN {  
 # ----------------------------------- Read loncapa.conf and loncapa_apache.conf  
     unless ($readit) {  
 {  
     my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');  
     %perlvar = (%perlvar,%{$configvars});  
 }  
   
 sub get_dns {  sub get_dns {
     my ($url,$func) = @_;      my ($url,$func) = @_;
     open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");      open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
Line 7630  sub get_dns { Line 7738  sub get_dns {
  $this_domain{$field} = shift(@elements);   $this_domain{$field} = shift(@elements);
     }      }
     $domain{$name} = \%this_domain;      $domain{$name} = \%this_domain;
     &logthis("Domain.tab: $name ".$domain{$name}{'description'} );  
  }   }
     }      }
           
Line 7679  sub get_dns { Line 7786  sub get_dns {
  $hostdom{$id}=$domain;   $hostdom{$id}=$domain;
  if ($role eq 'library') { $libserv{$id}=$name; }   if ($role eq 'library') { $libserv{$id}=$name; }
     }      }
     &logthis("Hosts.tab: $name ".$id );  
  }   }
     }      }
   
Line 7692  sub get_dns { Line 7798  sub get_dns {
  $loaded=1;   $loaded=1;
     }      }
   
     # FIXME: dev server don't want this, production servers _do_ want this  
     #&get_iphost();  
   
     sub hostname {      sub hostname {
  &load_hosts_tab() if (!$loaded);   &load_hosts_tab() if (!$loaded);
   
Line 7761  sub get_dns { Line 7864  sub get_dns {
   
 {   { 
     my %iphost;      my %iphost;
       my %name_to_ip;
       my %lonid_to_ip;
     sub get_hosts_from_ip {      sub get_hosts_from_ip {
  my ($ip) = @_;   my ($ip) = @_;
  my %iphosts = &get_iphost();   my %iphosts = &get_iphost();
Line 7769  sub get_dns { Line 7874  sub get_dns {
  }   }
  return;   return;
     }      }
   
       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 {      sub get_iphost {
  if (%iphost) { return %iphost; }   if (%iphost) { return %iphost; }
  my %name_to_ip;  
  my %hostname = &all_hostnames();   my %hostname = &all_hostnames();
  foreach my $id (keys(%hostname)) {   foreach my $id (keys(%hostname)) {
     my $name=$hostname{$id};      my $name=$hostname{$id};
Line 7788  sub get_dns { Line 7906  sub get_dns {
     } else {      } else {
  $ip = $name_to_ip{$name};   $ip = $name_to_ip{$name};
     }      }
       $lonid_to_ip{$id} = $ip;
     push(@{$iphost{$ip}},$id);      push(@{$iphost{$ip}},$id);
  }   }
  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 8125  X<userenvironment()> Line 8254  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 8154  explanation of a user role term Line 8293  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 8588  critical subroutine Line 8729  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.853  
changed lines
  Added in v.1.862

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