[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.843 and 1.846

version 1.843, 2007/03/03 02:10:59 version 1.846, 2007/03/08 01:58:41
Line 35  use HTTP::Headers; Line 35  use HTTP::Headers;
 use HTTP::Date;  use HTTP::Date;
 # use Date::Parse;  # use Date::Parse;
 use vars   use vars 
 qw(%perlvar %badServerCache %iphost %spareid %hostdom   qw(%perlvar %badServerCache %iphost %spareid 
    %libserv %pr %prp $memcache %packagetab      %pr %prp $memcache %packagetab 
    %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount      %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf     %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
    %domaindescription %domain_auth_def %domain_auth_arg_def   
    %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary  
    $tmpdir $_64bit %env);     $tmpdir $_64bit %env);
   
 use IO::Socket;  use IO::Socket;
Line 727  sub get_dom { Line 725  sub get_dom {
     }      }
     $items=~s/\&$//;      $items=~s/\&$//;
     if (!$udom) { $udom=$env{'user.domain'}; }      if (!$udom) { $udom=$env{'user.domain'}; }
     if (exists($domain_primary{$udom})) {      if (defined(&domain($udom,'primary'))) {
         my $uhome=$domain_primary{$udom};          my $uhome=&domain($udom,'primary');
         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 751  sub get_dom { Line 749  sub get_dom {
 sub put_dom {  sub put_dom {
     my ($namespace,$storehash,$udom)=@_;      my ($namespace,$storehash,$udom)=@_;
     if (!$udom) { $udom=$env{'user.domain'}; }      if (!$udom) { $udom=$env{'user.domain'}; }
     if (exists($domain_primary{$udom})) {      if (defined(&domain($udom,'primary'))) {
         my $uhome=$domain_primary{$udom};          my $uhome=&domain($udom,'primary');
         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 767  sub put_dom { Line 765  sub put_dom {
 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 1842  sub flushcourselogs { Line 1840  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 2097  sub get_my_roles { Line 2095  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 2131  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 2168  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 4170  sub definerole { Line 4174  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 4811  sub modifyuser { Line 4816  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 5043  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 7404  sub current_machine_domains { Line 7409  sub current_machine_domains {
     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;
Line 7561  BEGIN { Line 7566  BEGIN {
   
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
 {  {
     %domaindescription = ();      my %domain;
     %domain_auth_def = ();  
     %domain_auth_arg_def = ();  
     my $fh;      my $fh;
     if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {      if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {
  while (my $line = <$fh>) {   while (my $line = <$fh>) {
            next if ($line =~ /^(\#|\s*$)/);      next if ($line =~ /^(\#|\s*$ )/);
 #           next if /^\#/;  
            chomp $line;  
            my ($domain, $domain_description, $def_auth, $def_auth_arg,  
        $def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9);  
    $domain_auth_def{$domain}=$def_auth;  
            $domain_auth_arg_def{$domain}=$def_auth_arg;  
    $domaindescription{$domain}=$domain_description;  
    $domain_lang_def{$domain}=$def_lang;  
    $domain_city{$domain}=$city;  
    $domain_longi{$domain}=$longi;  
    $domain_lati{$domain}=$lati;  
            $domain_primary{$domain}=$primary;  
   
  #         &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");      chomp($line);
       my ($name,@elements) =  split(/:/,$line,9);
       my %this_domain;
       foreach my $field ('description', 'auth_def', 'auth_arg_def',
          'lang_def', 'city', 'longi', 'lati',
          'primary') {
    $this_domain{$field} = shift(@elements);
       }
       $domain{$name} = \%this_domain;
 #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );  #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
  }   }
     }      }
     close ($fh);      close ($fh);
   
       sub domain {
    my ($name,$what) = @_;
    return if ( !exists($domain{$name}) );
   
    if (!$what) {
       return $domain{$name}{'description'};
    }
    return $domain{$name}{$what};
       }
 }  }
   
   
 # ------------------------------------------------------------- Read hosts file  # ------------------------------------------------------------- Read hosts file
 {  {
     my %hostname;      my %hostname;
       my %hostdom;
       my %libserv;
     open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");      open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
Line 7613  BEGIN { Line 7625  BEGIN {
  my ($lonid) = @_;   my ($lonid) = @_;
  return $hostname{$lonid};   return $hostname{$lonid};
     }      }
   
     sub all_hostnames {      sub all_hostnames {
  return %hostname;   return %hostname;
     }      }
   
       sub is_library {
    return exists($libserv{$_[0]});
       }
   
       sub all_library {
    return %libserv;
       }
   
     sub get_servers {      sub get_servers {
  my ($domain,$type) = @_;   my ($domain,$type) = @_;
  my %possible_hosts = ($type eq 'library') ? %libserv   my %possible_hosts = ($type eq 'library') ? %libserv
Line 7636  BEGIN { Line 7658  BEGIN {
  }   }
  return %result;   return %result;
     }      }
   
       sub host_domain {
    my ($lonid) = @_;
    return $hostdom{$lonid};
       }
   
     sub all_domains {      sub all_domains {
  my %seen;   my %seen;
  my @uniq = grep(!$seen{$_}++, values(%hostdom));   my @uniq = grep(!$seen{$_}++, values(%hostdom));
Removed from v.1.843  
changed lines
  Added in v.1.846

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