[BACK]Return to lond CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.305.2.2 and 1.323

version 1.305.2.2, 2006/02/02 10:32:31 version 1.323, 2006/03/04 00:59:59
Line 89  my $ConnectionType; Line 89  my $ConnectionType;
   
 my %hostid; # ID's for hosts in cluster by ip.  my %hostid; # ID's for hosts in cluster by ip.
 my %hostdom; # LonCAPA domain for hosts in cluster.  my %hostdom; # LonCAPA domain for hosts in cluster.
   my %hostname; # DNSname -> ID's mapping.
 my %hostip; # IPs for hosts in cluster.  my %hostip; # IPs for hosts in cluster.
 my %hostdns; # ID's of hosts looked up by DNS name.  my %hostdns; # ID's of hosts looked up by DNS name.
   
Line 2975  sub dump_with_regexp { Line 2976  sub dump_with_regexp {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail);      my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail);
     if (defined($regexp)) {      if (defined($regexp)) {
  $regexp=&unescape($regexp);   $regexp=&unescape($regexp);
     } else {      } else {
  $regexp='.';   $regexp='.';
     }      }
       my ($start,$end);
       if (defined($range)) {
    if ($range =~/^(\d+)\-(\d+)$/) {
       ($start,$end) = ($1,$2);
    } elsif ($range =~/^(\d+)$/) {
       ($start,$end) = (0,$1);
    } else {
       undef($range);
    }
       }
     my $hashref = &tie_user_hash($udom, $uname, $namespace,      my $hashref = &tie_user_hash($udom, $uname, $namespace,
  &GDBM_READER());   &GDBM_READER());
     if ($hashref) {      if ($hashref) {
         my $qresult='';          my $qresult='';
    my $count=0;
  while (my ($key,$value) = each(%$hashref)) {   while (my ($key,$value) = each(%$hashref)) {
     if ($regexp eq '.') {      if ($regexp eq '.') {
    $count++;
    if (defined($range) && $count >= $end)   { last; }
    if (defined($range) && $count <  $start) { next; }
  $qresult.=$key.'='.$value.'&';   $qresult.=$key.'='.$value.'&';
     } else {      } else {
  my $unescapeKey = &unescape($key);   my $unescapeKey = &unescape($key);
  if (eval('$unescapeKey=~/$regexp/')) {   if (eval('$unescapeKey=~/$regexp/')) {
       $count++;
       if (defined($range) && $count >= $end)   { last; }
       if (defined($range) && $count <  $start) { next; }
     $qresult.="$key=$value&";      $qresult.="$key=$value&";
  }   }
     }      }
Line 3075  sub store_handler { Line 3093  sub store_handler {
 }  }
 &register_handler("store", \&store_handler, 0, 1, 0);  &register_handler("store", \&store_handler, 0, 1, 0);
   
   #  Modify a set of key=value pairs associated with a versioned name.
   #
   #  Parameters:
   #    $cmd                - Request command keyword.
   #    $tail               - Tail of the request.  This is a colon
   #                          separated list containing:
   #                          domain/user - User and authentication domain.
   #                          namespace   - Name of the database being modified
   #                          rid         - Resource keyword to modify.
   #                          v           - Version item to modify
   #                          what        - new value associated with rid.
   #
   #    $client             - Socket open on the client.
   #
   #
   #  Returns:
   #      1 (keep on processing).
   #  Side-Effects:
   #    Writes to the client
   sub putstore_handler {
       my ($cmd, $tail, $client) = @_;
    
       my $userinput = "$cmd:$tail";
   
       my ($udom,$uname,$namespace,$rid,$v,$what) =split(/:/,$tail);
       if ($namespace ne 'roles') {
   
    chomp($what);
    my $hashref  = &tie_user_hash($udom, $uname, $namespace,
          &GDBM_WRCREAT(), "M",
          "$rid:$v:$what");
    if ($hashref) {
       my $now = time;
       my %data = &hash_extract($what);
       my @allkeys;
       while (my($key,$value) = each(%data)) {
    push(@allkeys,$key);
    $hashref->{"$v:$rid:$key"} = $value;
       }
       my $allkeys = join(':',@allkeys);
       $hashref->{"$v:keys:$rid"}=$allkeys;
   
       if (&untie_user_hash($hashref)) {
    &Reply($client, "ok\n", $userinput);
       } else {
    &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
    "while attempting store\n", $userinput);
       }
    } else {
       &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
        "while attempting store\n", $userinput);
    }
       } else {
    &Failure($client, "refused\n", $userinput);
       }
   
       return 1;
   }
   &register_handler("putstore", \&putstore_handler, 0, 1, 0);
   
   sub hash_extract {
       my ($str)=@_;
       my %hash;
       foreach my $pair (split(/\&/,$str)) {
    my ($key,$value)=split(/=/,$pair);
    $hash{$key}=$value;
       }
       return (%hash);
   }
   sub hash_to_str {
       my ($hash_ref)=@_;
       my $str;
       foreach my $key (keys(%$hash_ref)) {
    $str.=$key.'='.$hash_ref->{$key}.'&';
       }
       $str=~s/\&$//;
       return $str;
   }
   
 #  #
 #  Dump out all versions of a resource that has key=value pairs associated  #  Dump out all versions of a resource that has key=value pairs associated
 # with it for each version.  These resources are built up via the store  # with it for each version.  These resources are built up via the store
Line 4318  sub get_institutional_code_format_handle Line 4415  sub get_institutional_code_format_handle
 &register_handler("autoinstcodeformat",  &register_handler("autoinstcodeformat",
   \&get_institutional_code_format_handler,0,1,0);    \&get_institutional_code_format_handler,0,1,0);
   
   # Get domain specific conditions for import of student photographs to a course
   #
   # Retrieves information from photo_permission subroutine in localenroll.
   # Returns outcome (ok) if no processing errors, and whether course owner is 
   # required to accept conditions of use (yes/no).
   #
   #    
   sub photo_permission_handler {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my $cdom = $tail;
       my ($perm_reqd,$conditions);
       my $outcome;
       eval {
    local($SIG{__DIE__})='DEFAULT';
    $outcome = &localenroll::photo_permission($cdom,\$perm_reqd,
     \$conditions);
       };
       if (!$@) {
    &Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n",
          $userinput);
       } else {
    &Failure($client,"unknown_cmd\n",$userinput);
       }
       return 1;
   }
   &register_handler("autophotopermission",\&photo_permission_handler,0,1,0);
   
   #
   # Checks if student photo is available for a user in the domain, in the user's
   # directory (in /userfiles/internal/studentphoto.jpg).
   # Uses localstudentphoto:fetch() to ensure there is an up to date copy of
   # the student's photo.   
   
   sub photo_check_handler {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my ($udom,$uname,$pid) = split(/:/,$tail);
       $udom = &unescape($udom);
       $uname = &unescape($uname);
       $pid = &unescape($pid);
       my $path=&propath($udom,$uname).'/userfiles/internal/';
       if (!-e $path) {
           &mkpath($path);
       }
       my $response;
       my $result = &localstudentphoto::fetch($udom,$uname,$pid,\$response);
       $result .= ':'.$response;
       &Reply($client, &escape($result)."\n",$userinput);
       return 1;
   }
   &register_handler("autophotocheck",\&photo_check_handler,0,1,0);
   
   #
   # Retrieve information from localenroll about whether to provide a button     
   # for users who have enbled import of student photos to initiate an 
   # update of photo files for registered students. Also include 
   # comment to display alongside button.  
   
   sub photo_choice_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput             = "$cmd:$tail";
       my $cdom                  = &unescape($tail);
       my ($update,$comment);
       eval {
    local($SIG{__DIE__})='DEFAULT';
    ($update,$comment)    = &localenroll::manager_photo_update($cdom);
       };
       if (!$@) {
    &Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput);
       } else {
    &Failure($client,"unknown_cmd\n",$userinput);
       }
       return 1;
   }
   &register_handler("autophotochoice",\&photo_choice_handler,0,1,0);
   
 #  #
 # Gets a student's photo to exist (in the correct image type) in the user's   # Gets a student's photo to exist (in the correct image type) in the user's 
 # directory.  # directory.
Line 4330  sub get_institutional_code_format_handle Line 4504  sub get_institutional_code_format_handle
 #    $client  - The socket open on the client.  #    $client  - The socket open on the client.
 # Returns:  # Returns:
 #    1 - continue processing.  #    1 - continue processing.
   
 sub student_photo_handler {  sub student_photo_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
     my ($domain,$uname,$type) = split(/:/, $tail);      my ($domain,$uname,$ext,$type) = split(/:/, $tail);
   
     my $path=&propath($domain,$uname).      my $path=&propath($domain,$uname). '/userfiles/internal/';
  '/userfiles/internal/studentphoto.'.$type;      my $filename = 'studentphoto.'.$ext;
     if (-e $path) {      if ($type eq 'thumbnail') {
           $filename = 'studentphoto_tn.'.$ext;
       }
       if (-e $path.$filename) {
  &Reply($client,"ok\n","$cmd:$tail");   &Reply($client,"ok\n","$cmd:$tail");
  return 1;   return 1;
     }      }
     &mkpath($path);      &mkpath($path);
     my $file=&localstudentphoto::fetch($domain,$uname);      my $file;
       if ($type eq 'thumbnail') {
    eval {
       local($SIG{__DIE__})='DEFAULT';
       $file=&localstudentphoto::fetch_thumbnail($domain,$uname);
    };
       } else {
           $file=&localstudentphoto::fetch($domain,$uname);
       }
     if (!$file) {      if (!$file) {
  &Failure($client,"unavailable\n","$cmd:$tail");   &Failure($client,"unavailable\n","$cmd:$tail");
  return 1;   return 1;
     }      }
     if (!-e $path) { &convert_photo($file,$path); }      if (!-e $path.$filename) { &convert_photo($file,$path.$filename); }
     if (-e $path) {      if (-e $path.$filename) {
  &Reply($client,"ok\n","$cmd:$tail");   &Reply($client,"ok\n","$cmd:$tail");
  return 1;   return 1;
     }      }
Line 4408  sub process_request { Line 4594  sub process_request {
                                 # fix all the userinput -> user_input.                                  # fix all the userinput -> user_input.
     my $wasenc    = 0; # True if request was encrypted.      my $wasenc    = 0; # True if request was encrypted.
 # ------------------------------------------------------------ See if encrypted  # ------------------------------------------------------------ See if encrypted
       # for command
       # sethost:<server>
       # <command>:<args>
       #   we just send it to the processor
       # for
       # sethost:<server>:<command>:<args>
       #  we do the implict set host and then do the command
       if ($userinput =~ /^sethost:/) {
    (my $cmd,my $newid,$userinput) = split(':',$userinput,3);
    if (defined($userinput)) {
       &sethost("$cmd:$newid");
    } else {
       $userinput = "$cmd:$newid";
    }
       }
   
     if ($userinput =~ /^enc/) {      if ($userinput =~ /^enc/) {
  $userinput = decipher($userinput);   $userinput = decipher($userinput);
  $wasenc=1;   $wasenc=1;
Line 4762  sub ReadHostTable { Line 4964  sub ReadHostTable {
     }      }
     $hostid{$ip}=$id;         # LonCAPA name of host by IP.      $hostid{$ip}=$id;         # LonCAPA name of host by IP.
     $hostdom{$id}=$domain;    # LonCAPA domain name of host.       $hostdom{$id}=$domain;    # LonCAPA domain name of host. 
       $hostname{$id}=$name;     # LonCAPA name -> DNS name
     $hostip{$id}=$ip;         # IP address of host.      $hostip{$id}=$ip;         # IP address of host.
     $hostdns{$name} = $id;    # LonCAPA name of host by DNS.      $hostdns{$name} = $id;    # LonCAPA name of host by DNS.
   
Line 5012  sub reconlonc { Line 5215  sub reconlonc {
   
 sub subreply {  sub subreply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     my $peerfile="$perlvar{'lonSockDir'}/$server";      my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",      my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                                       Type    => SOCK_STREAM,                                        Type    => SOCK_STREAM,
                                       Timeout => 10)                                        Timeout => 10)
        or return "con_lost";         or return "con_lost";
     print $sclient "$cmd\n";      print $sclient "sethost:$server:$cmd\n";
     my $answer=<$sclient>;      my $answer=<$sclient>;
     chomp($answer);      chomp($answer);
     if (!$answer) { $answer="con_lost"; }      if (!$answer) { $answer="con_lost"; }
Line 5033  sub reply { Line 5236  sub reply {
  $answer=subreply("ping",$server);   $answer=subreply("ping",$server);
         if ($answer ne $server) {          if ($answer ne $server) {
     &logthis("sub reply: answer != server answer is $answer, server is $server");      &logthis("sub reply: answer != server answer is $answer, server is $server");
            &reconlonc("$perlvar{'lonSockDir'}/$server");             &reconlonc("$perlvar{'lonSockDir'}/".$hostname{$server});
         }          }
         $answer=subreply($cmd,$server);          $answer=subreply($cmd,$server);
     }      }
Line 5060  sub sub_sql_reply { Line 5263  sub sub_sql_reply {
                                       Type    => SOCK_STREAM,                                        Type    => SOCK_STREAM,
                                       Timeout => 10)                                        Timeout => 10)
        or return "con_lost";         or return "con_lost";
     print $sclient "$cmd\n";      print $sclient "$cmd:$currentdomainid\n";
     my $answer=<$sclient>;      my $answer=<$sclient>;
     chomp($answer);      chomp($answer);
     if (!$answer) { $answer="con_lost"; }      if (!$answer) { $answer="con_lost"; }
Line 5339  sub make_new_child { Line 5542  sub make_new_child {
     # no need to try to do recon's to myself      # no need to try to do recon's to myself
     next;      next;
  }   }
  &reconlonc("$perlvar{'lonSockDir'}/$id");   &reconlonc("$perlvar{'lonSockDir'}/".$hostname{$id});
     }      }
     &logthis("<font color='green'>Established connection: $clientname</font>");      &logthis("<font color='green'>Established connection: $clientname</font>");
     &status('Will listen to '.$clientname);      &status('Will listen to '.$clientname);
Line 5395  sub is_author { Line 5598  sub is_author {
   
     #  Author role should show up as a key /domain/_au      #  Author role should show up as a key /domain/_au
   
     my $key   = "/$domain/_au";      my $key    = "/$domain/_au";
     my $value = $hashref->{$key};      my $value;
       if (defined($hashref)) {
    $value = $hashref->{$key};
       }
   
     if(defined($value)) {      if(defined($value)) {
  &Debug("$user @ $domain is an author");   &Debug("$user @ $domain is an author");
Line 5996  sub convert_photo { Line 6202  sub convert_photo {
 sub sethost {  sub sethost {
     my ($remotereq) = @_;      my ($remotereq) = @_;
     my (undef,$hostid)=split(/:/,$remotereq);      my (undef,$hostid)=split(/:/,$remotereq);
       # ignore sethost if we are already correct
       if ($hostid eq $currenthostid) {
    return 'ok';
       }
   
     if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }      if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
     if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {      if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
  $currenthostid  =$hostid;   $currenthostid  =$hostid;
Removed from v.1.305.2.2  
changed lines
  Added in v.1.323

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