version 1.310, 2006/01/31 04:40:12
|
version 1.331, 2006/05/30 15:39:56
|
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; |
use IO::File; |
use IO::File; |
#use Apache::File; |
#use Apache::File; |
use Symbol; |
|
use POSIX; |
use POSIX; |
use Crypt::IDEA; |
use Crypt::IDEA; |
use LWP::UserAgent(); |
use LWP::UserAgent(); |
Line 939 sub EditFile {
|
Line 939 sub EditFile {
|
return "ok\n"; |
return "ok\n"; |
} |
} |
|
|
#--------------------------------------------------------------- |
|
# |
|
# Manipulation of hash based databases (factoring out common code |
|
# for later use as we refactor. |
|
# |
|
# Ties a domain level resource file to a hash. |
|
# If requested a history entry is created in the associated hist file. |
|
# |
|
# Parameters: |
|
# domain - Name of the domain in which the resource file lives. |
|
# namespace - Name of the hash within that domain. |
|
# how - How to tie the hash (e.g. GDBM_WRCREAT()). |
|
# loghead - Optional parameter, if present a log entry is created |
|
# in the associated history file and this is the first part |
|
# of that entry. |
|
# logtail - Goes along with loghead, The actual logentry is of the |
|
# form $loghead:<timestamp>:logtail. |
|
# Returns: |
|
# Reference to a hash bound to the db file or alternatively undef |
|
# if the tie failed. |
|
# |
|
sub tie_domain_hash { |
|
my ($domain,$namespace,$how,$loghead,$logtail) = @_; |
|
|
|
# Filter out any whitespace in the domain name: |
|
|
|
$domain =~ s/\W//g; |
|
|
|
# We have enough to go on to tie the hash: |
|
|
|
my $user_top_dir = $perlvar{'lonUsersDir'}; |
|
my $domain_dir = $user_top_dir."/$domain"; |
|
my $resource_file = $domain_dir."/$namespace.db"; |
|
my %hash; |
|
if(tie(%hash, 'GDBM_File', $resource_file, $how, 0640)) { |
|
if (defined($loghead)) { # Need to log the operation. |
|
my $logFh = IO::File->new(">>$domain_dir/$namespace.hist"); |
|
if($logFh) { |
|
my $timestamp = time; |
|
print $logFh "$loghead:$timestamp:$logtail\n"; |
|
} |
|
$logFh->close; |
|
} |
|
return \%hash; # Return the tied hash. |
|
} else { |
|
return undef; # Tie failed. |
|
} |
|
} |
|
|
|
# |
|
# Ties a user's resource file to a hash. |
|
# If necessary, an appropriate history |
|
# log file entry is made as well. |
|
# This sub factors out common code from the subs that manipulate |
|
# the various gdbm files that keep keyword value pairs. |
|
# Parameters: |
|
# domain - Name of the domain the user is in. |
|
# user - Name of the 'current user'. |
|
# namespace - Namespace representing the file to tie. |
|
# how - What the tie is done to (e.g. GDBM_WRCREAT(). |
|
# loghead - Optional first part of log entry if there may be a |
|
# history file. |
|
# what - Optional tail of log entry if there may be a history |
|
# file. |
|
# Returns: |
|
# hash to which the database is tied. It's up to the caller to untie. |
|
# undef if the has could not be tied. |
|
# |
|
sub tie_user_hash { |
|
my ($domain,$user,$namespace,$how,$loghead,$what) = @_; |
|
|
|
$namespace=~s/\//\_/g; # / -> _ |
|
$namespace=~s/\W//g; # whitespace eliminated. |
|
my $proname = propath($domain, $user); |
|
|
|
# Tie the database. |
|
|
|
my %hash; |
|
if(tie(%hash, 'GDBM_File', "$proname/$namespace.db", |
|
$how, 0640)) { |
|
# If this is a namespace for which a history is kept, |
|
# make the history log entry: |
|
if (($namespace !~/^nohist\_/) && (defined($loghead))) { |
|
my $args = scalar @_; |
|
Debug(" Opening history: $namespace $args"); |
|
my $hfh = IO::File->new(">>$proname/$namespace.hist"); |
|
if($hfh) { |
|
my $now = time; |
|
print $hfh "$loghead:$now:$what\n"; |
|
} |
|
$hfh->close; |
|
} |
|
return \%hash; |
|
} else { |
|
return undef; |
|
} |
|
|
|
} |
|
|
|
# read_profile |
# read_profile |
# |
# |
# Returns a set of specific entries from a user's profile file. |
# Returns a set of specific entries from a user's profile file. |
Line 1068 sub read_profile {
|
Line 969 sub read_profile {
|
$qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string. |
$qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string. |
} |
} |
$qresult=~s/\&$//; # Remove trailing & from last lookup. |
$qresult=~s/\&$//; # Remove trailing & from last lookup. |
if (untie %$hashref) { |
if (&untie_user_hash($hashref)) { |
return $qresult; |
return $qresult; |
} else { |
} else { |
return "error: ".($!+0)." untie (GDBM) Failed"; |
return "error: ".($!+0)." untie (GDBM) Failed"; |
Line 2226 sub token_auth_user_file_handler {
|
Line 2127 sub token_auth_user_file_handler {
|
if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. |
if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. |
$session.'.id')) { |
$session.'.id')) { |
while (my $line=<ENVIN>) { |
while (my $line=<ENVIN>) { |
if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply="ok\n"; } |
my ($envname)=split(/=/,$line,2); |
|
$envname=&unescape($envname); |
|
if ($envname=~ m|^userfile\.\Q$fname\E|) { $reply="ok\n"; } |
} |
} |
close(ENVIN); |
close(ENVIN); |
&Reply($client, $reply, "$cmd:$tail"); |
&Reply($client, $reply, "$cmd:$tail"); |
Line 2377 sub put_user_profile_entry {
|
Line 2280 sub put_user_profile_entry {
|
my ($key,$value)=split(/=/,$pair); |
my ($key,$value)=split(/=/,$pair); |
$hashref->{$key}=$value; |
$hashref->{$key}=$value; |
} |
} |
if (untie(%$hashref)) { |
if (&untie_user_hash($hashref)) { |
&Reply( $client, "ok\n", $userinput); |
&Reply( $client, "ok\n", $userinput); |
} else { |
} else { |
&Failure($client, "error: ".($!+0)." untie(GDBM) failed ". |
&Failure($client, "error: ".($!+0)." untie(GDBM) failed ". |
Line 2385 sub put_user_profile_entry {
|
Line 2288 sub put_user_profile_entry {
|
$userinput); |
$userinput); |
} |
} |
} else { |
} else { |
&Failure( $client, "error: ".($!)." tie(GDBM) Failed ". |
&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". |
"while attempting put\n", $userinput); |
"while attempting put\n", $userinput); |
} |
} |
} else { |
} else { |
Line 2421 sub newput_user_profile_entry {
|
Line 2324 sub newput_user_profile_entry {
|
my $hashref = &tie_user_hash($udom, $uname, $namespace, |
my $hashref = &tie_user_hash($udom, $uname, $namespace, |
&GDBM_WRCREAT(),"N",$what); |
&GDBM_WRCREAT(),"N",$what); |
if(!$hashref) { |
if(!$hashref) { |
&Failure( $client, "error: ".($!)." tie(GDBM) Failed ". |
&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". |
"while attempting put\n", $userinput); |
"while attempting put\n", $userinput); |
return 1; |
return 1; |
} |
} |
Line 2440 sub newput_user_profile_entry {
|
Line 2343 sub newput_user_profile_entry {
|
$hashref->{$key}=$value; |
$hashref->{$key}=$value; |
} |
} |
|
|
if (untie(%$hashref)) { |
if (&untie_user_hash($hashref)) { |
&Reply( $client, "ok\n", $userinput); |
&Reply( $client, "ok\n", $userinput); |
} else { |
} else { |
&Failure($client, "error: ".($!+0)." untie(GDBM) failed ". |
&Failure($client, "error: ".($!+0)." untie(GDBM) failed ". |
Line 2493 sub increment_user_value_handler {
|
Line 2396 sub increment_user_value_handler {
|
} |
} |
} |
} |
} |
} |
if (untie(%$hashref)) { |
if (&untie_user_hash($hashref)) { |
&Reply( $client, "ok\n", $userinput); |
&Reply( $client, "ok\n", $userinput); |
} else { |
} else { |
&Failure($client, "error: ".($!+0)." untie(GDBM) failed ". |
&Failure($client, "error: ".($!+0)." untie(GDBM) failed ". |
Line 2560 sub roles_put_handler {
|
Line 2463 sub roles_put_handler {
|
$auth_type); |
$auth_type); |
$hashref->{$key}=$value; |
$hashref->{$key}=$value; |
} |
} |
if (untie($hashref)) { |
if (&untie_user_hash($hashref)) { |
&Reply($client, "ok\n", $userinput); |
&Reply($client, "ok\n", $userinput); |
} else { |
} else { |
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". |
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". |
Line 2611 sub roles_delete_handler {
|
Line 2514 sub roles_delete_handler {
|
foreach my $key (@rolekeys) { |
foreach my $key (@rolekeys) { |
delete $hashref->{$key}; |
delete $hashref->{$key}; |
} |
} |
if (untie(%$hashref)) { |
if (&untie_user_hash($hashref)) { |
&Reply($client, "ok\n", $userinput); |
&Reply($client, "ok\n", $userinput); |
} else { |
} else { |
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". |
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". |
Line 2752 sub delete_profile_entry {
|
Line 2655 sub delete_profile_entry {
|
foreach my $key (@keys) { |
foreach my $key (@keys) { |
delete($hashref->{$key}); |
delete($hashref->{$key}); |
} |
} |
if (untie(%$hashref)) { |
if (&untie_user_hash($hashref)) { |
&Reply($client, "ok\n", $userinput); |
&Reply($client, "ok\n", $userinput); |
} else { |
} else { |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
Line 2794 sub get_profile_keys {
|
Line 2697 sub get_profile_keys {
|
foreach my $key (keys %$hashref) { |
foreach my $key (keys %$hashref) { |
$qresult.="$key&"; |
$qresult.="$key&"; |
} |
} |
if (untie(%$hashref)) { |
if (&untie_user_hash($hashref)) { |
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
&Reply($client, "$qresult\n", $userinput); |
&Reply($client, "$qresult\n", $userinput); |
} else { |
} else { |
Line 2855 sub dump_profile_database {
|
Line 2758 sub dump_profile_database {
|
$data{$symb}->{$param}=$value; |
$data{$symb}->{$param}=$value; |
$data{$symb}->{'v.'.$param}=$v; |
$data{$symb}->{'v.'.$param}=$v; |
} |
} |
if (untie(%$hashref)) { |
if (&untie_user_hash($hashref)) { |
while (my ($symb,$param_hash) = each(%data)) { |
while (my ($symb,$param_hash) = each(%data)) { |
while(my ($param,$value) = each (%$param_hash)){ |
while(my ($param,$value) = each (%$param_hash)){ |
next if ($param =~ /^v\./); # Ignore versions... |
next if ($param =~ /^v\./); # Ignore versions... |
Line 2947 sub dump_with_regexp {
|
Line 2850 sub dump_with_regexp {
|
} |
} |
} |
} |
} |
} |
if (untie(%$hashref)) { |
if (&untie_user_hash($hashref)) { |
chop($qresult); |
chop($qresult); |
&Reply($client, "$qresult\n", $userinput); |
&Reply($client, "$qresult\n", $userinput); |
} else { |
} else { |
Line 3009 sub store_handler {
|
Line 2912 sub store_handler {
|
$hashref->{"$version:$rid:timestamp"}=$now; |
$hashref->{"$version:$rid:timestamp"}=$now; |
$allkeys.='timestamp'; |
$allkeys.='timestamp'; |
$hashref->{"$version:keys:$rid"}=$allkeys; |
$hashref->{"$version:keys:$rid"}=$allkeys; |
if (untie($hashref)) { |
if (&untie_user_hash($hashref)) { |
&Reply($client, "ok\n", $userinput); |
&Reply($client, "ok\n", $userinput); |
} else { |
} else { |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
Line 3027 sub store_handler {
|
Line 2930 sub store_handler {
|
} |
} |
®ister_handler("store", \&store_handler, 0, 1, 0); |
®ister_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; |
|
} |
|
®ister_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 3076 sub restore_handler {
|
Line 3058 sub restore_handler {
|
$qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&"; |
$qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&"; |
} |
} |
} |
} |
if (untie(%$hashref)) { |
if (&untie_user_hash($hashref)) { |
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
&Reply( $client, "$qresult\n", $userinput); |
&Reply( $client, "$qresult\n", $userinput); |
} else { |
} else { |
Line 3095 sub restore_handler {
|
Line 3077 sub restore_handler {
|
®ister_handler("restore", \&restore_handler, 0,1,0); |
®ister_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 3118 sub send_chat_handler {
|
Line 3102 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 3127 sub send_chat_handler {
|
Line 3111 sub send_chat_handler {
|
®ister_handler("chatsend", \&send_chat_handler, 0, 1, 0); |
®ister_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 3137 sub send_chat_handler {
|
Line 3121 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 3149 sub retrieve_chat_handler {
|
Line 3135 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 3309 sub put_course_id_handler {
|
Line 3295 sub put_course_id_handler {
|
} |
} |
$hashref->{$key}=$courseinfo.':'.$now; |
$hashref->{$key}=$courseinfo.':'.$now; |
} |
} |
if (untie(%$hashref)) { |
if (&untie_domain_hash($hashref)) { |
&Reply( $client, "ok\n", $userinput); |
&Reply( $client, "ok\n", $userinput); |
} else { |
} else { |
&Failure($client, "error: ".($!+0) |
&Failure($client, "error: ".($!+0) |
Line 3425 sub dump_course_id_handler {
|
Line 3411 sub dump_course_id_handler {
|
$qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&'; |
$qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&'; |
} |
} |
} |
} |
if (untie(%$hashref)) { |
if (&untie_domain_hash($hashref)) { |
chop($qresult); |
chop($qresult); |
&Reply($client, "$qresult\n", $userinput); |
&Reply($client, "$qresult\n", $userinput); |
} else { |
} else { |
Line 3474 sub put_id_handler {
|
Line 3460 sub put_id_handler {
|
my ($key,$value)=split(/=/,$pair); |
my ($key,$value)=split(/=/,$pair); |
$hashref->{$key}=$value; |
$hashref->{$key}=$value; |
} |
} |
if (untie(%$hashref)) { |
if (&untie_domain_hash($hashref)) { |
&Reply($client, "ok\n", $userinput); |
&Reply($client, "ok\n", $userinput); |
} else { |
} else { |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
Line 3523 sub get_id_handler {
|
Line 3509 sub get_id_handler {
|
for (my $i=0;$i<=$#queries;$i++) { |
for (my $i=0;$i<=$#queries;$i++) { |
$qresult.="$hashref->{$queries[$i]}&"; |
$qresult.="$hashref->{$queries[$i]}&"; |
} |
} |
if (untie(%$hashref)) { |
if (&untie_domain_hash($hashref)) { |
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
&Reply($client, "$qresult\n", $userinput); |
&Reply($client, "$qresult\n", $userinput); |
} else { |
} else { |
Line 3567 sub put_dcmail_handler {
|
Line 3553 sub put_dcmail_handler {
|
my ($key,$value)=split(/=/,$what); |
my ($key,$value)=split(/=/,$what); |
$hashref->{$key}=$value; |
$hashref->{$key}=$value; |
} |
} |
if (untie(%$hashref)) { |
if (&untie_domain_hash($hashref)) { |
&Reply($client, "ok\n", $userinput); |
&Reply($client, "ok\n", $userinput); |
} else { |
} else { |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
Line 3647 sub dump_dcmail_handler {
|
Line 3633 sub dump_dcmail_handler {
|
$qresult.=$key.'='.$value.'&'; |
$qresult.=$key.'='.$value.'&'; |
} |
} |
} |
} |
if (untie(%$hashref)) { |
if (&untie_domain_hash($hashref)) { |
chop($qresult); |
chop($qresult); |
&Reply($client, "$qresult\n", $userinput); |
&Reply($client, "$qresult\n", $userinput); |
} else { |
} else { |
Line 3694 sub put_domainroles_handler {
|
Line 3680 sub put_domainroles_handler {
|
my ($key,$value)=split(/=/,$pair); |
my ($key,$value)=split(/=/,$pair); |
$hashref->{$key}=$value; |
$hashref->{$key}=$value; |
} |
} |
if (untie(%$hashref)) { |
if (&untie_domain_hash($hashref)) { |
&Reply($client, "ok\n", $userinput); |
&Reply($client, "ok\n", $userinput); |
} else { |
} else { |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
Line 3775 sub dump_domainroles_handler {
|
Line 3761 sub dump_domainroles_handler {
|
$qresult.=$key.'='.$value.'&'; |
$qresult.=$key.'='.$value.'&'; |
} |
} |
} |
} |
if (untie(%$hashref)) { |
if (&untie_domain_hash($hashref)) { |
chop($qresult); |
chop($qresult); |
&Reply($client, "$qresult\n", $userinput); |
&Reply($client, "$qresult\n", $userinput); |
} else { |
} else { |
Line 4270 sub get_institutional_code_format_handle
|
Line 4256 sub get_institutional_code_format_handle
|
®ister_handler("autoinstcodeformat", |
®ister_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; |
|
} |
|
®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 |
# Gets a student's photo to exist (in the correct image type) in the user's |
# directory. |
# directory. |
Line 4282 sub get_institutional_code_format_handle
|
Line 4345 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 4360 sub process_request {
|
Line 4435 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 4923 sub status {
|
Line 5014 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 5013 sub sub_sql_reply {
|
Line 5088 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"; } |
return $answer; |
return $answer; |
} |
} |
|
|
# -------------------------------------------- Return path to profile directory |
|
|
|
sub propath { |
|
my ($udom,$uname)=@_; |
|
$udom=~s/\W//g; |
|
$uname=~s/\W//g; |
|
my $subdir=$uname.'__'; |
|
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
|
my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; |
|
return $proname; |
|
} |
|
|
|
# --------------------------------------- Is this the home server of an author? |
# --------------------------------------- Is this the home server of an author? |
|
|
sub ishome { |
sub ishome { |
Line 5348 sub is_author {
|
Line 5411 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 5622 sub addline {
|
Line 5688 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)); |
untie(%$hashref); |
&untie_user_hash($hashref); |
} |
} |
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 5642 sub get_chat {
|
Line 5714 sub get_chat {
|
push(@participants, 'active_participant:'.$user); |
push(@participants, 'active_participant:'.$user); |
} |
} |
} |
} |
untie(%$hashref); |
&untie_user_hash($hashref); |
} |
} |
return (@participants,@entries); |
return (@participants,@entries); |
} |
} |
|
|
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 5674 sub chat_add {
|
Line 5752 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); |
} |
} |
untie(%$hashref); |
&untie_user_hash($hashref); |
} |
} |
} |
} |
|
|
Line 5949 sub convert_photo {
|
Line 6027 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; |
Line 6374 to the client, and the connection is clo
|
Line 6457 to the client, and the connection is clo
|
IO::Socket |
IO::Socket |
IO::File |
IO::File |
Apache::File |
Apache::File |
Symbol |
|
POSIX |
POSIX |
Crypt::IDEA |
Crypt::IDEA |
LWP::UserAgent() |
LWP::UserAgent() |