--- loncom/lond 2006/02/10 09:48:17 1.305.2.4 +++ loncom/lond 2006/01/31 15:56:46 1.312 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.305.2.4 2006/02/10 09:48:17 albertel Exp $ +# $Id: lond,v 1.312 2006/01/31 15:56:46 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -53,15 +53,13 @@ use LONCAPA::ConfigFileEdit; use LONCAPA::lonlocal; use LONCAPA::lonssl; use Fcntl qw(:flock); -use Symbol; my $DEBUG = 0; # Non zero to enable debug log entries. my $status=''; my $lastlog=''; -my $lond_max_wait_time = 13; -my $VERSION='$Revision: 1.305.2.4 $'; #' stupid emacs +my $VERSION='$Revision: 1.312 $'; #' stupid emacs my $remoteVERSION; my $currenthostid="default"; my $currentdomainid; @@ -89,6 +87,7 @@ my $ConnectionType; my %hostid; # ID's for hosts in cluster by ip. my %hostdom; # LonCAPA domain for hosts in cluster. +my %hostname; # DNSname -> ID's mapping. my %hostip; # IPs for hosts in cluster. my %hostdns; # ID's of hosts looked up by DNS name. @@ -973,11 +972,11 @@ sub tie_domain_hash { my $user_top_dir = $perlvar{'lonUsersDir'}; my $domain_dir = $user_top_dir."/$domain"; my $resource_file = $domain_dir."/$namespace"; - return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail); + return &_do_hash_tie($resource_file,$namespace,$how,$loghead,$logtail); } sub untie_domain_hash { - return &_locking_hash_untie(@_); + return &_do_hash_untie(@_); } # # Ties a user's resource file to a hash. @@ -1006,11 +1005,11 @@ sub tie_user_hash { my $proname = propath($domain, $user); my $file_prefix="$proname/$namespace"; - return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what); + return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what); } sub untie_user_hash { - return &_locking_hash_untie(@_); + return &_do_hash_untie(@_); } # internal routines that handle the actual tieing and untieing process @@ -1042,67 +1041,6 @@ sub _do_hash_untie { my $result = untie(%$hashref); return $result; } - -{ - my $sym; - - sub _locking_hash_tie { - my ($file_prefix,$namespace,$how,$loghead,$what) = @_; - - my ($lock); - - if ($how eq &GDBM_READER()) { - $lock=LOCK_SH; - $how=$how|&GDBM_NOLOCK(); - #if the db doesn't exist we can't read from it - if (! -e "$file_prefix.db") { - $! = 2; - return undef; - } - } elsif ($how eq &GDBM_WRCREAT()) { - $lock=LOCK_EX; - $how=$how|&GDBM_NOLOCK(); - if (! -e "$file_prefix.db") { - # doesn't exist but we need it to in order to successfully - # lock it so bring it into existance - open(TOUCH,">>$file_prefix.db"); - close(TOUCH); - } - } else { - &logthis("Unknown method $how for $file_prefix"); - die(); - } - - $sym=&Symbol::gensym(); - open($sym,"$file_prefix.db"); - my $failed=0; - eval { - local $SIG{__DIE__}='DEFAULT'; - local $SIG{ALRM}=sub { - $failed=1; - die("failed lock"); - }; - alarm($lond_max_wait_time); - flock($sym,$lock); - alarm(0); - }; - if ($failed) { - $! = 100; # throwing error # 100 - return undef; - } - return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what); - } - - sub _locking_hash_untie { - my ($hashref) = @_; - my $result = untie(%$hashref); - flock($sym,LOCK_UN); - close($sym); - undef($sym); - return $result; - } -} - # read_profile # # Returns a set of specific entries from a user's profile file. @@ -2450,7 +2388,7 @@ sub put_user_profile_entry { $userinput); } } else { - &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". + &Failure( $client, "error: ".($!)." tie(GDBM) Failed ". "while attempting put\n", $userinput); } } else { @@ -2486,7 +2424,7 @@ sub newput_user_profile_entry { my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_WRCREAT(),"N",$what); if(!$hashref) { - &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". + &Failure( $client, "error: ".($!)." tie(GDBM) Failed ". "while attempting put\n", $userinput); return 1; } @@ -2676,7 +2614,7 @@ sub roles_delete_handler { foreach my $key (@rolekeys) { delete $hashref->{$key}; } - if (&untie_user_hash($hashref)) { + if (&untie_user_hash(%$hashref)) { &Reply($client, "ok\n", $userinput); } else { &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". @@ -2817,7 +2755,7 @@ sub delete_profile_entry { foreach my $key (@keys) { delete($hashref->{$key}); } - if (&untie_user_hash($hashref)) { + if (&untie_user_hash(%$hashref)) { &Reply($client, "ok\n", $userinput); } else { &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". @@ -2859,7 +2797,7 @@ sub get_profile_keys { foreach my $key (keys %$hashref) { $qresult.="$key&"; } - if (&untie_user_hash($hashref)) { + if (&untie_user_hash(%$hashref)) { $qresult=~s/\&$//; &Reply($client, "$qresult\n", $userinput); } else { @@ -2975,22 +2913,39 @@ sub dump_with_regexp { my $userinput = "$cmd:$tail"; - my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail); + my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail); if (defined($regexp)) { $regexp=&unescape($regexp); } else { $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, &GDBM_READER()); if ($hashref) { my $qresult=''; + my $count=0; while (my ($key,$value) = each(%$hashref)) { if ($regexp eq '.') { + $count++; + if (defined($range) && $count >= $end) { last; } + if (defined($range) && $count < $start) { next; } $qresult.=$key.'='.$value.'&'; } else { my $unescapeKey = &unescape($key); if (eval('$unescapeKey=~/$regexp/')) { + $count++; + if (defined($range) && $count >= $end) { last; } + if (defined($range) && $count < $start) { next; } $qresult.="$key=$value&"; } } @@ -4318,83 +4273,6 @@ sub get_institutional_code_format_handle ®ister_handler("autoinstcodeformat", \&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; -} -®ister_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; -} -®ister_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; -} -®ister_handler("autophotochoice",\&photo_choice_handler,0,1,0); - # # Gets a student's photo to exist (in the correct image type) in the user's # directory. @@ -4407,36 +4285,24 @@ sub photo_choice_handler { # $client - The socket open on the client. # Returns: # 1 - continue processing. - sub student_photo_handler { my ($cmd, $tail, $client) = @_; - my ($domain,$uname,$ext,$type) = split(/:/, $tail); + my ($domain,$uname,$type) = split(/:/, $tail); - my $path=&propath($domain,$uname). '/userfiles/internal/'; - my $filename = 'studentphoto.'.$ext; - if ($type eq 'thumbnail') { - $filename = 'studentphoto_tn.'.$ext; - } - if (-e $path.$filename) { + my $path=&propath($domain,$uname). + '/userfiles/internal/studentphoto.'.$type; + if (-e $path) { &Reply($client,"ok\n","$cmd:$tail"); return 1; } &mkpath($path); - my $file; - if ($type eq 'thumbnail') { - eval { - local($SIG{__DIE__})='DEFAULT'; - $file=&localstudentphoto::fetch_thumbnail($domain,$uname); - }; - } else { - $file=&localstudentphoto::fetch($domain,$uname); - } + my $file=&localstudentphoto::fetch($domain,$uname); if (!$file) { &Failure($client,"unavailable\n","$cmd:$tail"); return 1; } - if (!-e $path.$filename) { &convert_photo($file,$path.$filename); } - if (-e $path.$filename) { + if (!-e $path) { &convert_photo($file,$path); } + if (-e $path) { &Reply($client,"ok\n","$cmd:$tail"); return 1; } @@ -4851,6 +4717,7 @@ sub ReadHostTable { } $hostid{$ip}=$id; # LonCAPA name of host by IP. $hostdom{$id}=$domain; # LonCAPA domain name of host. + $hostname{$id}=$name; # LonCAPA name -> DNS name $hostip{$id}=$ip; # IP address of host. $hostdns{$name} = $id; # LonCAPA name of host by DNS. @@ -5101,12 +4968,12 @@ sub reconlonc { sub subreply { my ($cmd,$server)=@_; - my $peerfile="$perlvar{'lonSockDir'}/$server"; + my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server}; my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", Type => SOCK_STREAM, Timeout => 10) or return "con_lost"; - print $sclient "$cmd\n"; + print $sclient "sethost:$server:$cmd\n"; my $answer=<$sclient>; chomp($answer); if (!$answer) { $answer="con_lost"; } @@ -5122,7 +4989,7 @@ sub reply { $answer=subreply("ping",$server); if ($answer ne $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); } @@ -5428,7 +5295,7 @@ sub make_new_child { # no need to try to do recon's to myself next; } - &reconlonc("$perlvar{'lonSockDir'}/$id"); + &reconlonc("$perlvar{'lonSockDir'}/".$hostname{$id}); } &logthis("Established connection: $clientname"); &status('Will listen to '.$clientname);