version 1.200, 2004/06/21 13:25:53
|
version 1.209, 2004/07/23 14:10:47
|
Line 51 use LONCAPA::ConfigFileEdit;
|
Line 51 use LONCAPA::ConfigFileEdit;
|
use LONCAPA::lonlocal; |
use LONCAPA::lonlocal; |
use LONCAPA::lonssl; |
use LONCAPA::lonssl; |
|
|
my $DEBUG = 11; # Non zero to enable debug log entries. |
my $DEBUG = 0; # Non zero to enable debug log entries. |
|
|
my $status=''; |
my $status=''; |
my $lastlog=''; |
my $lastlog=''; |
Line 71 my $thisserver; # DNS of us.
|
Line 71 my $thisserver; # DNS of us.
|
|
|
my $keymode; |
my $keymode; |
|
|
|
my $cipher; # Cipher key negotiated with client |
|
my $tmpsnum = 0; # Id of tmpputs. |
|
|
# |
# |
# Connection type is: |
# Connection type is: |
# client - All client actions are allowed |
# client - All client actions are allowed |
Line 90 my %managers; # Ip -> manager names
|
Line 93 my %managers; # Ip -> manager names
|
my %perlvar; # Will have the apache conf defined perl vars. |
my %perlvar; # Will have the apache conf defined perl vars. |
|
|
# |
# |
|
# The hash below is used for command dispatching, and is therefore keyed on the request keyword. |
|
# Each element of the hash contains a reference to an array that contains: |
|
# A reference to a sub that executes the request corresponding to the keyword. |
|
# A flag that is true if the request must be encoded to be acceptable. |
|
# A mask with bits as follows: |
|
# CLIENT_OK - Set when the function is allowed by ordinary clients |
|
# MANAGER_OK - Set when the function is allowed to manager clients. |
|
# |
|
my $CLIENT_OK = 1; |
|
my $MANAGER_OK = 2; |
|
my %Dispatcher; |
|
|
|
|
|
# |
# The array below are password error strings." |
# The array below are password error strings." |
# |
# |
my $lastpwderror = 13; # Largest error number from lcpasswd. |
my $lastpwderror = 13; # Largest error number from lcpasswd. |
Line 127 my @adderrors = ("ok",
|
Line 144 my @adderrors = ("ok",
|
"lcuseradd Password mismatch"); |
"lcuseradd Password mismatch"); |
|
|
|
|
|
|
|
# |
|
# Statistics that are maintained and dislayed in the status line. |
|
# |
|
my $Transactions; # Number of attempted transactions. |
|
my $Failures; # Number of transcations failed. |
|
|
|
# ResetStatistics: |
|
# Resets the statistics counters: |
|
# |
|
sub ResetStatistics { |
|
$Transactions = 0; |
|
$Failures = 0; |
|
} |
|
|
|
|
|
|
#------------------------------------------------------------------------ |
#------------------------------------------------------------------------ |
# |
# |
# LocalConnection |
# LocalConnection |
Line 354 sub ReadManagerTable {
|
Line 388 sub ReadManagerTable {
|
while(my $host = <MANAGERS>) { |
while(my $host = <MANAGERS>) { |
chomp($host); |
chomp($host); |
if ($host =~ "^#") { # Comment line. |
if ($host =~ "^#") { # Comment line. |
logthis('<font color="green"> Skipping line: '. "$host</font>\n"); |
|
next; |
next; |
} |
} |
if (!defined $hostip{$host}) { # This is a non cluster member |
if (!defined $hostip{$host}) { # This is a non cluster member |
Line 900 sub EditFile {
|
Line 933 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) = @_; |
|
|
|
# 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 (scalar @_) { # Need to log the operation. |
|
my $logFh = IO::File->new(">>domain_dir/$namespace.hist"); |
|
if($logFh) { |
|
my $timestamp = time; |
|
my ($loghead, $logtail) = @_; |
|
print $logFh "$loghead:$timestamp:$logtail\n"; |
|
} |
|
} |
|
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 TieUserHash { |
|
my ($domain, |
|
$user, |
|
$namespace, |
|
$how) = @_; |
|
|
|
|
|
$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\_/) && (scalar @_ > 0)) { |
|
my $args = scalar @_; |
|
Debug(" Opening history: $namespace $args"); |
|
my $hfh = IO::File->new(">>$proname/$namespace.hist"); |
|
if($hfh) { |
|
my $now = time; |
|
my $loghead = shift; |
|
my $what = shift; |
|
print $hfh "$loghead:$now:$what\n"; |
|
} |
|
} |
|
return \%hash; |
|
} else { |
|
return undef; |
|
} |
|
|
|
} |
|
#--------------------------------------------------------------- |
|
# |
|
# Getting, decoding and dispatching requests: |
|
# |
|
|
|
# |
|
# Get a Request: |
|
# Gets a Request message from the client. The transaction |
|
# is defined as a 'line' of text. We remove the new line |
|
# from the text line. |
|
# |
|
sub GetRequest { |
|
my $input = <$client>; |
|
chomp($input); |
|
|
|
Debug("Request = $input\n"); |
|
|
|
&status('Processing '.$clientname.':'.$input); |
|
|
|
return $input; |
|
} |
|
# |
|
# Decipher encoded traffic |
|
# Parameters: |
|
# input - Encoded data. |
|
# Returns: |
|
# Decoded data or undef if encryption key was not yet negotiated. |
|
# Implicit input: |
|
# cipher - This global holds the negotiated encryption key. |
|
# |
|
sub Decipher { |
|
my ($input) = @_; |
|
my $output = ''; |
|
|
|
|
|
if($cipher) { |
|
my($enc, $enclength, $encinput) = split(/:/, $input); |
|
for(my $encidx = 0; $encidx < length($encinput); $encidx += 16) { |
|
$output .= |
|
$cipher->decrypt(pack("H16", substr($encinput, $encidx, 16))); |
|
} |
|
return substr($output, 0, $enclength); |
|
} else { |
|
return undef; |
|
} |
|
} |
|
|
|
# |
|
# Register a command processor. This function is invoked to register a sub |
|
# to process a request. Once registered, the ProcessRequest sub can automatically |
|
# dispatch requests to an appropriate sub, and do the top level validity checking |
|
# as well: |
|
# - Is the keyword recognized. |
|
# - Is the proper client type attempting the request. |
|
# - Is the request encrypted if it has to be. |
|
# Parameters: |
|
# $request_name - Name of the request being registered. |
|
# This is the command request that will match |
|
# against the hash keywords to lookup the information |
|
# associated with the dispatch information. |
|
# $procedure - Reference to a sub to call to process the request. |
|
# All subs get called as follows: |
|
# Procedure($cmd, $tail, $replyfd, $key) |
|
# $cmd - the actual keyword that invoked us. |
|
# $tail - the tail of the request that invoked us. |
|
# $replyfd- File descriptor connected to the client |
|
# $must_encode - True if the request must be encoded to be good. |
|
# $client_ok - True if it's ok for a client to request this. |
|
# $manager_ok - True if it's ok for a manager to request this. |
|
# Side effects: |
|
# - On success, the Dispatcher hash has an entry added for the key $RequestName |
|
# - On failure, the program will die as it's a bad internal bug to try to |
|
# register a duplicate command handler. |
|
# |
|
sub RegisterHandler { |
|
my ($request_name, |
|
$procedure, |
|
$must_encode, |
|
$client_ok, |
|
$manager_ok) = @_; |
|
|
|
# Don't allow duplication# |
|
|
|
if (defined $Dispatcher{$request_name}) { |
|
die "Attempting to define a duplicate request handler for $request_name\n"; |
|
} |
|
# Build the client type mask: |
|
|
|
my $client_type_mask = 0; |
|
if($client_ok) { |
|
$client_type_mask |= $CLIENT_OK; |
|
} |
|
if($manager_ok) { |
|
$client_type_mask |= $MANAGER_OK; |
|
} |
|
|
|
# Enter the hash: |
|
|
|
my @entry = ($procedure, $must_encode, $client_type_mask); |
|
|
|
$Dispatcher{$request_name} = \@entry; |
|
|
|
|
|
} |
|
|
|
|
|
#------------------------------------------------------------------ |
|
|
|
|
|
|
|
|
# |
# |
# Convert an error return code from lcpasswd to a string value. |
# Convert an error return code from lcpasswd to a string value. |
# |
# |
Line 1426 while (1) {
|
Line 1677 while (1) {
|
|
|
sub make_new_child { |
sub make_new_child { |
my $pid; |
my $pid; |
my $cipher; |
# my $cipher; # Now global |
my $sigset; |
my $sigset; |
|
|
$client = shift; |
$client = shift; |
Line 1485 sub make_new_child {
|
Line 1736 sub make_new_child {
|
sigprocmask(SIG_UNBLOCK, $sigset) |
sigprocmask(SIG_UNBLOCK, $sigset) |
or die "Can't unblock SIGINT for fork: $!\n"; |
or die "Can't unblock SIGINT for fork: $!\n"; |
|
|
my $tmpsnum=0; |
# my $tmpsnum=0; # Now global |
#---------------------------------------------------- kerberos 5 initialization |
#---------------------------------------------------- kerberos 5 initialization |
&Authen::Krb5::init_context(); |
&Authen::Krb5::init_context(); |
&Authen::Krb5::init_ets(); |
&Authen::Krb5::init_ets(); |
Line 2234 sub make_new_child {
|
Line 2485 sub make_new_child {
|
} elsif ($userinput =~ /^put/) { |
} elsif ($userinput =~ /^put/) { |
if(isClient) { |
if(isClient) { |
my ($cmd,$udom,$uname,$namespace,$what) |
my ($cmd,$udom,$uname,$namespace,$what) |
=split(/:/,$userinput); |
=split(/:/,$userinput,5); |
$namespace=~s/\//\_/g; |
$namespace=~s/\//\_/g; |
$namespace=~s/\W//g; |
$namespace=~s/\W//g; |
if ($namespace ne 'roles') { |
if ($namespace ne 'roles') { |
chomp($what); |
chomp($what); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $now=time; |
my $now=time; |
unless ($namespace=~/^nohist\_/) { |
|
my $hfh; |
|
if ( |
|
$hfh=IO::File->new(">>$proname/$namespace.hist") |
|
) { print $hfh "P:$now:$what\n"; } |
|
} |
|
my @pairs=split(/\&/,$what); |
my @pairs=split(/\&/,$what); |
my %hash; |
my %hash; |
if (tie(%hash,'GDBM_File', |
if (tie(%hash,'GDBM_File', |
"$proname/$namespace.db", |
"$proname/$namespace.db", |
&GDBM_WRCREAT(),0640)) { |
&GDBM_WRCREAT(),0640)) { |
|
unless ($namespace=~/^nohist\_/) { |
|
my $hfh; |
|
if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; } |
|
} |
|
|
foreach my $pair (@pairs) { |
foreach my $pair (@pairs) { |
my ($key,$value)=split(/=/,$pair); |
my ($key,$value)=split(/=/,$pair); |
$hash{$key}=$value; |
$hash{$key}=$value; |
Line 2286 sub make_new_child {
|
Line 2536 sub make_new_child {
|
chomp($what); |
chomp($what); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $now=time; |
my $now=time; |
unless ($namespace=~/^nohist\_/) { |
|
my $hfh; |
|
if ( |
|
$hfh=IO::File->new(">>$proname/$namespace.hist") |
|
) { print $hfh "P:$now:$what\n"; } |
|
} |
|
my @pairs=split(/\&/,$what); |
my @pairs=split(/\&/,$what); |
my %hash; |
my %hash; |
if (tie(%hash,'GDBM_File', |
if (tie(%hash,'GDBM_File', |
"$proname/$namespace.db", |
"$proname/$namespace.db", |
&GDBM_WRCREAT(),0640)) { |
&GDBM_WRCREAT(),0640)) { |
|
unless ($namespace=~/^nohist\_/) { |
|
my $hfh; |
|
if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; } |
|
} |
foreach my $pair (@pairs) { |
foreach my $pair (@pairs) { |
my ($key,$value)=split(/=/,$pair); |
my ($key,$value)=split(/=/,$pair); |
# We could check that we have a number... |
# We could check that we have a number... |
Line 2338 sub make_new_child {
|
Line 2586 sub make_new_child {
|
chomp($what); |
chomp($what); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $now=time; |
my $now=time; |
{ |
|
my $hfh; |
|
if ( |
|
$hfh=IO::File->new(">>$proname/$namespace.hist") |
|
) { |
|
print $hfh "P:$now:$exedom:$exeuser:$what\n"; |
|
} |
|
} |
|
my @pairs=split(/\&/,$what); |
my @pairs=split(/\&/,$what); |
my %hash; |
my %hash; |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
|
{ |
|
my $hfh; |
|
if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { |
|
print $hfh "P:$now:$exedom:$exeuser:$what\n"; |
|
} |
|
} |
|
|
foreach my $pair (@pairs) { |
foreach my $pair (@pairs) { |
my ($key,$value)=split(/=/,$pair); |
my ($key,$value)=split(/=/,$pair); |
&ManagePermissions($key, $udom, $uname, |
&ManagePermissions($key, $udom, $uname, |
Line 2389 sub make_new_child {
|
Line 2636 sub make_new_child {
|
chomp($what); |
chomp($what); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $now=time; |
my $now=time; |
{ |
|
my $hfh; |
|
if ( |
|
$hfh=IO::File->new(">>$proname/$namespace.hist") |
|
) { |
|
print $hfh "D:$now:$exedom:$exeuser:$what\n"; |
|
} |
|
} |
|
my @rolekeys=split(/\&/,$what); |
my @rolekeys=split(/\&/,$what); |
my %hash; |
my %hash; |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
|
{ |
|
my $hfh; |
|
if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { |
|
print $hfh "D:$now:$exedom:$exeuser:$what\n"; |
|
} |
|
} |
foreach my $key (@rolekeys) { |
foreach my $key (@rolekeys) { |
delete $hash{$key}; |
delete $hash{$key}; |
} |
} |
Line 2516 sub make_new_child {
|
Line 2761 sub make_new_child {
|
chomp($what); |
chomp($what); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $now=time; |
my $now=time; |
unless ($namespace=~/^nohist\_/) { |
|
my $hfh; |
|
if ( |
|
$hfh=IO::File->new(">>$proname/$namespace.hist") |
|
) { print $hfh "D:$now:$what\n"; } |
|
} |
|
my @keys=split(/\&/,$what); |
my @keys=split(/\&/,$what); |
my %hash; |
my %hash; |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
|
unless ($namespace=~/^nohist\_/) { |
|
my $hfh; |
|
if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "D:$now:$what\n"; } |
|
} |
foreach my $key (@keys) { |
foreach my $key (@keys) { |
delete($hash{$key}); |
delete($hash{$key}); |
} |
} |
Line 2679 sub make_new_child {
|
Line 2922 sub make_new_child {
|
chomp($what); |
chomp($what); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $now=time; |
my $now=time; |
unless ($namespace=~/^nohist\_/) { |
|
my $hfh; |
|
if ( |
|
$hfh=IO::File->new(">>$proname/$namespace.hist") |
|
) { print $hfh "P:$now:$rid:$what\n"; } |
|
} |
|
my @pairs=split(/\&/,$what); |
my @pairs=split(/\&/,$what); |
my %hash; |
my %hash; |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
|
unless ($namespace=~/^nohist\_/) { |
|
my $hfh; |
|
if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { |
|
print $hfh "P:$now:$rid:$what\n"; |
|
} |
|
} |
my @previouskeys=split(/&/,$hash{"keys:$rid"}); |
my @previouskeys=split(/&/,$hash{"keys:$rid"}); |
my $key; |
my $key; |
$hash{"version:$rid"}++; |
$hash{"version:$rid"}++; |
Line 2836 sub make_new_child {
|
Line 3079 sub make_new_child {
|
my %hash; |
my %hash; |
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { |
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { |
foreach my $pair (@pairs) { |
foreach my $pair (@pairs) { |
my ($key,$value)=split(/=/,$pair); |
my ($key,$descr,$inst_code)=split(/=/,$pair); |
$hash{$key}=$value.':'.$now; |
$hash{$key}=$descr.':'.$inst_code.':'.$now; |
} |
} |
if (untie(%hash)) { |
if (untie(%hash)) { |
print $client "ok\n"; |
print $client "ok\n"; |
Line 2872 sub make_new_child {
|
Line 3115 sub make_new_child {
|
my %hash; |
my %hash; |
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { |
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { |
while (my ($key,$value) = each(%hash)) { |
while (my ($key,$value) = each(%hash)) { |
my ($descr,$lasttime)=split(/\:/,$value); |
my ($descr,$lasttime,$inst_code); |
|
if ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) { |
|
($descr,$inst_code,$lasttime)=($1,$2,$3); |
|
} else { |
|
($descr,$lasttime) = split(/\:/,$value); |
|
} |
if ($lasttime<$since) { next; } |
if ($lasttime<$since) { next; } |
if ($description eq '.') { |
if ($description eq '.') { |
$qresult.=$key.'='.$descr.'&'; |
$qresult.=$key.'='.$descr.':'.$inst_code.'&'; |
} else { |
} else { |
my $unescapeVal = &unescape($descr); |
my $unescapeVal = &unescape($descr); |
if (eval('$unescapeVal=~/\Q$description\E/i')) { |
if (eval('$unescapeVal=~/\Q$description\E/i')) { |
$qresult.="$key=$descr&"; |
$qresult.=$key.'='.$descr.':'.$inst_code.'&'; |
} |
} |
} |
} |
} |
} |
Line 2908 sub make_new_child {
|
Line 3156 sub make_new_child {
|
$udom=~s/\W//g; |
$udom=~s/\W//g; |
my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; |
my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; |
my $now=time; |
my $now=time; |
{ |
|
my $hfh; |
|
if ( |
|
$hfh=IO::File->new(">>$proname.hist") |
|
) { print $hfh "P:$now:$what\n"; } |
|
} |
|
my @pairs=split(/\&/,$what); |
my @pairs=split(/\&/,$what); |
my %hash; |
my %hash; |
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { |
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { |
|
{ |
|
my $hfh; |
|
if ($hfh=IO::File->new(">>$proname.hist")) { |
|
print $hfh "P:$now:$what\n"; |
|
} |
|
} |
foreach my $pair (@pairs) { |
foreach my $pair (@pairs) { |
my ($key,$value)=split(/=/,$pair); |
my ($key,$value)=split(/=/,$pair); |
$hash{$key}=$value; |
$hash{$key}=$value; |
Line 3033 sub make_new_child {
|
Line 3281 sub make_new_child {
|
Reply($client, "refused\n", $userinput); |
Reply($client, "refused\n", $userinput); |
|
|
} |
} |
|
# ----------------------------------------- portfolio directory list (portls) |
|
} elsif ($userinput =~ /^portls/) { |
|
if(isClient) { |
|
my ($cmd,$uname,$udom)=split(/:/,$userinput); |
|
my $udir=propath($udom,$uname).'/userfiles/portfolio'; |
|
my $dirLine=''; |
|
my $dirContents=''; |
|
if (opendir(LSDIR,$udir.'/')){ |
|
while ($dirLine = readdir(LSDIR)){ |
|
$dirContents = $dirContents.$dirLine.'<br />'; |
|
} |
|
} else { |
|
$dirContents = "No directory found\n"; |
|
} |
|
print $client $dirContents."\n"; |
|
} else { |
|
Reply($client, "refused\n", $userinput); |
|
} |
# -------------------------------------------------------------------------- ls |
# -------------------------------------------------------------------------- ls |
} elsif ($userinput =~ /^ls/) { |
} elsif ($userinput =~ /^ls/) { |
if(isClient) { |
if(isClient) { |
Line 3192 sub make_new_child {
|
Line 3458 sub make_new_child {
|
} else { |
} else { |
print $client "refused\n"; |
print $client "refused\n"; |
} |
} |
|
#--------------------- read and retrieve institutional code format (for support form). |
|
} elsif ($userinput =~/^autoinstcodeformat:/) { |
|
if (isClient) { |
|
my $reply; |
|
my($cmd,$cdom,$course) = split(/:/,$userinput); |
|
my @pairs = split/\&/,$course; |
|
my %instcodes = (); |
|
my %codes = (); |
|
my @codetitles = (); |
|
my %cat_titles = (); |
|
my %cat_order = (); |
|
foreach (@pairs) { |
|
my ($key,$value) = split/=/,$_; |
|
$instcodes{&unescape($key)} = &unescape($value); |
|
} |
|
my $formatreply = &localenroll::instcode_format($cdom,\%instcodes,\%codes,\@codetitles,\%cat_titles,\%cat_order); |
|
if ($formatreply eq 'ok') { |
|
my $codes_str = &hash2str(%codes); |
|
my $codetitles_str = &array2str(@codetitles); |
|
my $cat_titles_str = &hash2str(%cat_titles); |
|
my $cat_order_str = &hash2str(%cat_order); |
|
print $client $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'.$cat_order_str."\n"; |
|
} |
|
} else { |
|
print $client "refused\n"; |
|
} |
# ------------------------------------------------------------- unknown command |
# ------------------------------------------------------------- unknown command |
|
|
} else { |
} else { |
Line 3599 sub userload {
|
Line 3891 sub userload {
|
return $userloadpercent; |
return $userloadpercent; |
} |
} |
|
|
|
# Routines for serializing arrays and hashes (copies from lonnet) |
|
|
|
sub array2str { |
|
my (@array) = @_; |
|
my $result=&arrayref2str(\@array); |
|
$result=~s/^__ARRAY_REF__//; |
|
$result=~s/__END_ARRAY_REF__$//; |
|
return $result; |
|
} |
|
|
|
sub arrayref2str { |
|
my ($arrayref) = @_; |
|
my $result='__ARRAY_REF__'; |
|
foreach my $elem (@$arrayref) { |
|
if(ref($elem) eq 'ARRAY') { |
|
$result.=&arrayref2str($elem).'&'; |
|
} elsif(ref($elem) eq 'HASH') { |
|
$result.=&hashref2str($elem).'&'; |
|
} elsif(ref($elem)) { |
|
#print("Got a ref of ".(ref($elem))." skipping."); |
|
} else { |
|
$result.=&escape($elem).'&'; |
|
} |
|
} |
|
$result=~s/\&$//; |
|
$result .= '__END_ARRAY_REF__'; |
|
return $result; |
|
} |
|
|
|
sub hash2str { |
|
my (%hash) = @_; |
|
my $result=&hashref2str(\%hash); |
|
$result=~s/^__HASH_REF__//; |
|
$result=~s/__END_HASH_REF__$//; |
|
return $result; |
|
} |
|
|
|
sub hashref2str { |
|
my ($hashref)=@_; |
|
my $result='__HASH_REF__'; |
|
foreach (sort(keys(%$hashref))) { |
|
if (ref($_) eq 'ARRAY') { |
|
$result.=&arrayref2str($_).'='; |
|
} elsif (ref($_) eq 'HASH') { |
|
$result.=&hashref2str($_).'='; |
|
} elsif (ref($_)) { |
|
$result.='='; |
|
#print("Got a ref of ".(ref($_))." skipping."); |
|
} else { |
|
if ($_) {$result.=&escape($_).'=';} else { last; } |
|
} |
|
|
|
if(ref($hashref->{$_}) eq 'ARRAY') { |
|
$result.=&arrayref2str($hashref->{$_}).'&'; |
|
} elsif(ref($hashref->{$_}) eq 'HASH') { |
|
$result.=&hashref2str($hashref->{$_}).'&'; |
|
} elsif(ref($hashref->{$_})) { |
|
$result.='&'; |
|
#print("Got a ref of ".(ref($hashref->{$_}))." skipping."); |
|
} else { |
|
$result.=&escape($hashref->{$_}).'&'; |
|
} |
|
} |
|
$result=~s/\&$//; |
|
$result .= '__END_HASH_REF__'; |
|
return $result; |
|
} |
|
|
# ----------------------------------- POD (plain old documentation, CPAN style) |
# ----------------------------------- POD (plain old documentation, CPAN style) |
|
|