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

Diff for /loncom/lond between versions 1.318.2.2 and 1.326

version 1.318.2.2, 2006/02/09 20:39:25 version 1.326, 2006/05/13 01:31:15
Line 31 Line 31
   
 use strict;  use strict;
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
   use LONCAPA;
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
   
 use IO::Socket;  use IO::Socket;
Line 1050  sub _do_hash_untie { Line 1051  sub _do_hash_untie {
     sub _locking_hash_tie {      sub _locking_hash_tie {
  my ($file_prefix,$namespace,$how,$loghead,$what) = @_;   my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
   
   # is this locked by an external program?
   
           if (-e "$file_prefix.db.lock") {
       my $failed=0;
       eval {
    local $SIG{__DIE__}='DEFAULT';
    local $SIG{ALRM}=sub { 
       $failed=1;
       die("failed lock");
    };
    alarm(2*$lond_max_wait_time);
    while (-e "$file_prefix.db.lock") {}
    alarm(0);
       };
       if ($failed) {
    $! = 100; # throwing error # 100
    return undef;
       }
    }
   
   # is this archived?
   
           if (-e "$file_prefix.db.gz") {
   # lock immediately
       open(TOUCH,">>$file_prefix.db.lock");
      close(TOUCH);
              system("gunzip $file_prefix.db.gz");
      if (-e "$file_prefix.hist.gz") {
          system("gunzip $file_prefix.hist.gz");
      }
   # all set, unlock
              unlink("$file_prefix.db.lock");
          }
   
   
  my ($lock);   my ($lock);
           
  if ($how eq &GDBM_READER()) {   if ($how eq &GDBM_READER()) {
Line 3068  sub store_handler { Line 3104  sub store_handler {
     my $version=$hashref->{"version:$rid"};      my $version=$hashref->{"version:$rid"};
     my $allkeys='';       my $allkeys=''; 
     foreach my $pair (@pairs) {      foreach my $pair (@pairs) {
  my ($key)=split(/=/,$pair);   my ($key,$value)=split(/=/,$pair);
  $allkeys.=$key.':';   $allkeys.=$key.':';
    $hashref->{"$version:$rid:$key"}=$value;
     }      }
     $hashref->{"$version:$rid"}=$what."\&timestamp=$now";      $hashref->{"$version:$rid:timestamp"}=$now;
     $allkeys.='timestamp';      $allkeys.='timestamp';
     $hashref->{"$version:keys:$rid"}=$allkeys;      $hashref->{"$version:keys:$rid"}=$allkeys;
     if (&untie_user_hash($hashref)) {      if (&untie_user_hash($hashref)) {
Line 3092  sub store_handler { Line 3129  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 3137  sub restore_handler { Line 3253  sub restore_handler {
     my @keys=split(/:/,$vkeys);      my @keys=split(/:/,$vkeys);
     my $key;      my $key;
     $qresult.="$scope:keys=$vkeys&";      $qresult.="$scope:keys=$vkeys&";
     if (exists($hashref->{"$scope:$rid"})) {      foreach $key (@keys) {
  my $what=$hashref->{"$scope:$rid"};   $qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&";
  foreach my $pair (split(/\&/,$hashref->{"$scope:$rid"})) {      }                                  
     my ($key,$value)=split(/=/,$pair);  
     $qresult.="$scope:".$pair."&";  
  }  
     } else {  
  foreach $key (@keys) {  
     $qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&";  
  }  
     }  
  }   }
  if (&untie_user_hash($hashref)) {   if (&untie_user_hash($hashref)) {
     $qresult=~s/\&$//;      $qresult=~s/\&$//;
Line 3168  sub restore_handler { Line 3276  sub restore_handler {
 &register_handler("restore", \&restore_handler, 0,1,0);  &register_handler("restore", \&restore_handler, 0,1,0);
   
 #  #
 #   Add a chat message to to a discussion board.  #   Add a chat message to a synchronous discussion board.
 #  #
 # Parameters:  # Parameters:
 #    $cmd                - Request keyword.  #    $cmd                - Request keyword.
 #    $tail               - Tail of the command. A colon separated list  #    $tail               - Tail of the command. A colon separated list
 #                          containing:  #                          containing:
 #                          cdom    - Domain on which the chat board lives  #                          cdom    - Domain on which the chat board lives
 #                          cnum    - Identifier of the discussion group.  #                          cnum    - Course containing the chat board.
 #                          post    - Body of the posting.  #                          newpost - Body of the posting.
   #                          group   - Optional group, if chat board is only 
   #                                    accessible in a group within the course 
 #   $client              - Socket open on the client.  #   $client              - Socket open on the client.
 # Returns:  # Returns:
 #   1    - Indicating caller should keep on processing.  #   1    - Indicating caller should keep on processing.
Line 3191  sub send_chat_handler { Line 3301  sub send_chat_handler {
           
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($cdom,$cnum,$newpost)=split(/\:/,$tail);      my ($cdom,$cnum,$newpost,$group)=split(/\:/,$tail);
     &chat_add($cdom,$cnum,$newpost);      &chat_add($cdom,$cnum,$newpost,$group);
     &Reply($client, "ok\n", $userinput);      &Reply($client, "ok\n", $userinput);
   
     return 1;      return 1;
Line 3200  sub send_chat_handler { Line 3310  sub send_chat_handler {
 &register_handler("chatsend", \&send_chat_handler, 0, 1, 0);  &register_handler("chatsend", \&send_chat_handler, 0, 1, 0);
   
 #  #
 #   Retrieve the set of chat messagss from a discussion board.  #   Retrieve the set of chat messages from a discussion board.
 #  #
 #  Parameters:  #  Parameters:
 #    $cmd             - Command keyword that initiated the request.  #    $cmd             - Command keyword that initiated the request.
Line 3210  sub send_chat_handler { Line 3320  sub send_chat_handler {
 #                       chat id        - Discussion thread(?)  #                       chat id        - Discussion thread(?)
 #                       domain/user    - Authentication domain and username  #                       domain/user    - Authentication domain and username
 #                                        of the requesting person.  #                                        of the requesting person.
   #                       group          - Optional course group containing
   #                                        the board.      
 #   $client           - Socket open on the client program.  #   $client           - Socket open on the client program.
 # Returns:  # Returns:
 #    1     - continue processing  #    1     - continue processing
Line 3222  sub retrieve_chat_handler { Line 3334  sub retrieve_chat_handler {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail);      my ($cdom,$cnum,$udom,$uname,$group)=split(/\:/,$tail);
     my $reply='';      my $reply='';
     foreach (&get_chat($cdom,$cnum,$udom,$uname)) {      foreach (&get_chat($cdom,$cnum,$udom,$uname,$group)) {
  $reply.=&escape($_).':';   $reply.=&escape($_).':';
     }      }
     $reply=~s/\:$//;      $reply=~s/\:$//;
Line 4355  sub photo_permission_handler { Line 4467  sub photo_permission_handler {
     my $userinput               = "$cmd:$tail";      my $userinput               = "$cmd:$tail";
     my $cdom = $tail;      my $cdom = $tail;
     my ($perm_reqd,$conditions);      my ($perm_reqd,$conditions);
     my $outcome = &localenroll::photo_permission($cdom,\$perm_reqd,      my $outcome;
  \$conditions);      eval {
     &Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n",   local($SIG{__DIE__})='DEFAULT';
    $userinput);   $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);  &register_handler("autophotopermission",\&photo_permission_handler,0,1,0);
   
Line 4383  sub photo_check_handler { Line 4504  sub photo_check_handler {
     my $result = &localstudentphoto::fetch($udom,$uname,$pid,\$response);      my $result = &localstudentphoto::fetch($udom,$uname,$pid,\$response);
     $result .= ':'.$response;      $result .= ':'.$response;
     &Reply($client, &escape($result)."\n",$userinput);      &Reply($client, &escape($result)."\n",$userinput);
       return 1;
 }  }
 &register_handler("autophotocheck",\&photo_check_handler,0,1,0);  &register_handler("autophotocheck",\&photo_check_handler,0,1,0);
   
Line 4396  sub photo_choice_handler { Line 4518  sub photo_choice_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
     my $userinput             = "$cmd:$tail";      my $userinput             = "$cmd:$tail";
     my $cdom                  = &unescape($tail);      my $cdom                  = &unescape($tail);
     my ($update,$comment) = &localenroll::manager_photo_update($cdom);      my ($update,$comment);
     &Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput);      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);  &register_handler("autophotochoice",\&photo_choice_handler,0,1,0);
   
Line 4430  sub student_photo_handler { Line 4561  sub student_photo_handler {
     &mkpath($path);      &mkpath($path);
     my $file;      my $file;
     if ($type eq 'thumbnail') {      if ($type eq 'thumbnail') {
         $file=&localstudentphoto::fetch_thumbnail($domain,$uname);   eval {
       local($SIG{__DIE__})='DEFAULT';
       $file=&localstudentphoto::fetch_thumbnail($domain,$uname);
    };
     } else {      } else {
         $file=&localstudentphoto::fetch($domain,$uname);          $file=&localstudentphoto::fetch($domain,$uname);
     }      }
Line 4500  sub process_request { Line 4634  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 5063  sub status { Line 5213  sub status {
     $0='lond: '.$what.' '.$local;      $0='lond: '.$what.' '.$local;
 }  }
   
 # -------------------------------------------------------- Escape Special Chars  
   
 sub escape {  
     my $str=shift;  
     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;  
     return $str;  
 }  
   
 # ----------------------------------------------------- Un-Escape Special Chars  
   
 sub unescape {  
     my $str=shift;  
     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;  
     return $str;  
 }  
   
 # ----------------------------------------------------------- Send USR1 to lonc  # ----------------------------------------------------------- Send USR1 to lonc
   
 sub reconlonc {  sub reconlonc {
Line 5153  sub sub_sql_reply { Line 5287  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 5488  sub is_author { Line 5622  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 5762  sub addline { Line 5899  sub addline {
 }  }
   
 sub get_chat {  sub get_chat {
     my ($cdom,$cname,$udom,$uname)=@_;      my ($cdom,$cname,$udom,$uname,$group)=@_;
   
     my @entries=();      my @entries=();
     my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom',      my $namespace = 'nohist_chatroom';
       my $namespace_inroom = 'nohist_inchatroom';
       if (defined($group)) {
           $namespace .= '_'.$group;
           $namespace_inroom .= '_'.$group;
       }
       my $hashref = &tie_user_hash($cdom, $cname, $namespace,
  &GDBM_READER());   &GDBM_READER());
     if ($hashref) {      if ($hashref) {
  @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));   @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
Line 5773  sub get_chat { Line 5916  sub get_chat {
     }      }
     my @participants=();      my @participants=();
     my $cutoff=time-60;      my $cutoff=time-60;
     $hashref = &tie_user_hash($cdom, $cname, 'nohist_inchatroom',      $hashref = &tie_user_hash($cdom, $cname, $namespace_inroom,
       &GDBM_WRCREAT());        &GDBM_WRCREAT());
     if ($hashref) {      if ($hashref) {
         $hashref->{$uname.':'.$udom}=time;          $hashref->{$uname.':'.$udom}=time;
Line 5788  sub get_chat { Line 5931  sub get_chat {
 }  }
   
 sub chat_add {  sub chat_add {
     my ($cdom,$cname,$newchat)=@_;      my ($cdom,$cname,$newchat,$group)=@_;
     my @entries=();      my @entries=();
     my $time=time;      my $time=time;
     my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom',      my $namespace = 'nohist_chatroom';
       my $logfile = 'chatroom.log';
       if (defined($group)) {
           $namespace .= '_'.$group;
           $logfile = 'chatroom_'.$group.'.log';
       }
       my $hashref = &tie_user_hash($cdom, $cname, $namespace,
  &GDBM_WRCREAT());   &GDBM_WRCREAT());
     if ($hashref) {      if ($hashref) {
  @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));   @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
Line 5814  sub chat_add { Line 5963  sub chat_add {
  }   }
  {   {
     my $proname=&propath($cdom,$cname);      my $proname=&propath($cdom,$cname);
     if (open(CHATLOG,">>$proname/chatroom.log")) {       if (open(CHATLOG,">>$proname/$logfile")) { 
  print CHATLOG ("$time:".&unescape($newchat)."\n");   print CHATLOG ("$time:".&unescape($newchat)."\n");
     }      }
     close(CHATLOG);      close(CHATLOG);
Line 6089  sub convert_photo { Line 6238  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.318.2.2  
changed lines
  Added in v.1.326

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