|
version 1.411, 2009/02/10 11:31:26
|
version 1.433, 2009/11/12 15:59:00
|
|
Line 67 my $currentdomainid;
|
Line 67 my $currentdomainid;
|
| my $client; |
my $client; |
| my $clientip; # IP address of client. |
my $clientip; # IP address of client. |
| my $clientname; # LonCAPA name of client. |
my $clientname; # LonCAPA name of client. |
| |
my $clientversion; # LonCAPA version running on client |
| |
|
| my $server; |
my $server; |
| |
|
|
Line 142 my @adderrors = ("ok",
|
Line 143 my @adderrors = ("ok",
|
| "lcuseradd Password mismatch"); |
"lcuseradd Password mismatch"); |
| |
|
| |
|
| |
# This array are the errors from lcinstallfile: |
| |
|
| |
my @installerrors = ("ok", |
| |
"Initial user id of client not that of www", |
| |
"Usage error, not enough command line arguments", |
| |
"Source file name does not exist", |
| |
"Destination file name does not exist", |
| |
"Some file operation failed", |
| |
"Invalid table filename." |
| |
); |
| |
|
| # |
# |
| # Statistics that are maintained and dislayed in the status line. |
# Statistics that are maintained and dislayed in the status line. |
|
Line 398 sub isClient {
|
Line 409 sub isClient {
|
| # |
# |
| sub ReadManagerTable { |
sub ReadManagerTable { |
| |
|
| |
&Debug("Reading manager table"); |
| # Clean out the old table first.. |
# Clean out the old table first.. |
| |
|
| foreach my $key (keys %managers) { |
foreach my $key (keys %managers) { |
|
Line 520 sub AdjustHostContents {
|
Line 532 sub AdjustHostContents {
|
| } |
} |
| # |
# |
| # InstallFile: Called to install an administrative file: |
# InstallFile: Called to install an administrative file: |
| # - The file is created with <name>.tmp |
# - The file is created int a temp directory called <name>.tmp |
| # - The <name>.tmp file is then mv'd to <name> |
# - lcinstall file is called to install the file. |
| # This lugubrious procedure is done to ensure that we are never without |
# since the web app has no direct write access to the table directory |
| # a valid, even if dated, version of the file regardless of who crashes |
|
| # and when the crash occurs. |
|
| # |
# |
| # Parameters: |
# Parameters: |
| # Name of the file |
# Name of the file |
|
Line 532 sub AdjustHostContents {
|
Line 542 sub AdjustHostContents {
|
| # Return: |
# Return: |
| # nonzero - success. |
# nonzero - success. |
| # 0 - failure and $! has an errno. |
# 0 - failure and $! has an errno. |
| |
# Assumptions: |
| |
# File installtion is a relatively infrequent |
| # |
# |
| sub InstallFile { |
sub InstallFile { |
| |
|
| my ($Filename, $Contents) = @_; |
my ($Filename, $Contents) = @_; |
| my $TempFile = $Filename.".tmp"; |
# my $TempFile = $Filename.".tmp"; |
| |
my $exedir = $perlvar{'lonDaemons'}; |
| |
my $tmpdir = $exedir.'/tmp/'; |
| |
my $TempFile = $tmpdir."TempTableFile.tmp"; |
| |
|
| # Open the file for write: |
# Open the file for write: |
| |
|
|
Line 550 sub InstallFile {
|
Line 565 sub InstallFile {
|
| print $fh ($Contents); |
print $fh ($Contents); |
| $fh->close; # In case we ever have a filesystem w. locking |
$fh->close; # In case we ever have a filesystem w. locking |
| |
|
| chmod(0660, $TempFile); |
chmod(0664, $TempFile); # Everyone can write it. |
| |
|
| # Now we can move install the file in position. |
# Use lcinstall file to put the file in the table directory... |
| |
|
| move($TempFile, $Filename); |
&Debug("Opening pipe to $exedir/lcinstallfile $TempFile $Filename"); |
| |
my $pf = IO::File->new("| $exedir/lcinstallfile $TempFile $Filename > $exedir/logs/lcinstallfile.log"); |
| |
close $pf; |
| |
my $err = $?; |
| |
&Debug("Status is $err"); |
| |
if ($err != 0) { |
| |
my $msg = $err; |
| |
if ($err < @installerrors) { |
| |
$msg = $installerrors[$err]; |
| |
} |
| |
&logthis("Install failed for table file $Filename : $msg"); |
| |
return 0; |
| |
} |
| |
|
| |
# Remove the temp file: |
| |
|
| |
unlink($TempFile); |
| |
|
| return 1; |
return 1; |
| } |
} |
|
Line 608 sub ConfigFileFromSelector {
|
Line 639 sub ConfigFileFromSelector {
|
| sub PushFile { |
sub PushFile { |
| my $request = shift; |
my $request = shift; |
| my ($command, $filename, $contents) = split(":", $request, 3); |
my ($command, $filename, $contents) = split(":", $request, 3); |
| |
&Debug("PushFile"); |
| |
|
| # At this point in time, pushes for only the following tables are |
# At this point in time, pushes for only the following tables are |
| # supported: |
# supported: |
|
Line 624 sub PushFile {
|
Line 656 sub PushFile {
|
| if(! (defined $tablefile)) { |
if(! (defined $tablefile)) { |
| return "refused"; |
return "refused"; |
| } |
} |
| # |
|
| # >copy< the old table to the backup table |
|
| # don't rename in case system crashes/reboots etc. in the time |
|
| # window between a rename and write. |
|
| # |
|
| my $backupfile = $tablefile; |
|
| $backupfile =~ s/\.tab$/.old/; |
|
| if(!CopyFile($tablefile, $backupfile)) { |
|
| &logthis('<font color="green"> CopyFile from '.$tablefile." to ".$backupfile." failed </font>"); |
|
| return "error:$!"; |
|
| } |
|
| &logthis('<font color="green"> Pushfile: backed up ' |
|
| .$tablefile." to $backupfile</font>"); |
|
| |
|
| # If the file being pushed is the host file, we adjust the entry for ourself so that the |
# If the file being pushed is the host file, we adjust the entry for ourself so that the |
| # IP will be our current IP as looked up in dns. Note this is only 99% good as it's possible |
# IP will be our current IP as looked up in dns. Note this is only 99% good as it's possible |
| # to conceive of conditions where we don't have a DNS entry locally. This is possible in a |
# to conceive of conditions where we don't have a DNS entry locally. This is possible in a |
|
Line 650 sub PushFile {
|
Line 669 sub PushFile {
|
| |
|
| # Install the new file: |
# Install the new file: |
| |
|
| |
&logthis("Installing new $tablefile contents:\n$contents"); |
| if(!InstallFile($tablefile, $contents)) { |
if(!InstallFile($tablefile, $contents)) { |
| &logthis('<font color="red"> Pushfile: unable to install ' |
&logthis('<font color="red"> Pushfile: unable to install ' |
| .$tablefile." $! </font>"); |
.$tablefile." $! </font>"); |
|
Line 1203 sub user_authorization_type {
|
Line 1223 sub user_authorization_type {
|
| # a reply is written to the client. |
# a reply is written to the client. |
| sub push_file_handler { |
sub push_file_handler { |
| my ($cmd, $tail, $client) = @_; |
my ($cmd, $tail, $client) = @_; |
| |
&Debug("In push file handler"); |
| my $userinput = "$cmd:$tail"; |
my $userinput = "$cmd:$tail"; |
| |
|
| # At this time we only know that the IP of our partner is a valid manager |
# At this time we only know that the IP of our partner is a valid manager |
|
Line 1211 sub push_file_handler {
|
Line 1231 sub push_file_handler {
|
| # spoofing). |
# spoofing). |
| |
|
| my $cert = &GetCertificate($userinput); |
my $cert = &GetCertificate($userinput); |
| if(&ValidManager($cert)) { |
if(&ValidManager($cert)) { |
| |
&Debug("Valid manager: $client"); |
| |
|
| # Now presumably we have the bona fides of both the peer host and the |
# Now presumably we have the bona fides of both the peer host and the |
| # process making the request. |
# process making the request. |
|
Line 1220 sub push_file_handler {
|
Line 1241 sub push_file_handler {
|
| &Reply($client, \$reply, $userinput); |
&Reply($client, \$reply, $userinput); |
| |
|
| } else { |
} else { |
| |
&logthis("push_file_handler $client is not valid"); |
| &Failure( $client, "refused\n", $userinput); |
&Failure( $client, "refused\n", $userinput); |
| } |
} |
| return 1; |
return 1; |
|
Line 1624 sub server_timezone_handler {
|
Line 1646 sub server_timezone_handler {
|
| } |
} |
| ®ister_handler("servertimezone", \&server_timezone_handler, 0, 1, 0); |
®ister_handler("servertimezone", \&server_timezone_handler, 0, 1, 0); |
| |
|
| |
sub server_loncaparev_handler { |
| |
my ($cmd,$tail,$client) = @_; |
| |
my $userinput = "$cmd:$tail"; |
| |
&Reply($client,\$perlvar{'lonVersion'},$userinput); |
| |
return 1; |
| |
} |
| |
®ister_handler("serverloncaparev", \&server_loncaparev_handler, 0, 1, 0); |
| |
|
| # Process a reinit request. Reinit requests that either |
# Process a reinit request. Reinit requests that either |
| # lonc or lond be reinitialized so that an updated |
# lonc or lond be reinitialized so that an updated |
| # host.tab or domain.tab can be processed. |
# host.tab or domain.tab can be processed. |
|
Line 1786 sub change_password_handler {
|
Line 1816 sub change_password_handler {
|
| # npass - New password. |
# npass - New password. |
| # context - Context in which this was called |
# context - Context in which this was called |
| # (preferences or reset_by_email). |
# (preferences or reset_by_email). |
| |
# lonhost - HostID of server where request originated |
| |
|
| my ($udom,$uname,$upass,$npass,$context)=split(/:/,$tail); |
my ($udom,$uname,$upass,$npass,$context,$lonhost)=split(/:/,$tail); |
| |
|
| $upass=&unescape($upass); |
$upass=&unescape($upass); |
| $npass=&unescape($npass); |
$npass=&unescape($npass); |
|
Line 1796 sub change_password_handler {
|
Line 1827 sub change_password_handler {
|
| # First require that the user can be authenticated with their |
# First require that the user can be authenticated with their |
| # old password unless context was 'reset_by_email': |
# old password unless context was 'reset_by_email': |
| |
|
| my $validated; |
my ($validated,$failure); |
| if ($context eq 'reset_by_email') { |
if ($context eq 'reset_by_email') { |
| $validated = 1; |
if ($lonhost eq '') { |
| |
$failure = 'invalid_client'; |
| |
} else { |
| |
$validated = 1; |
| |
} |
| } else { |
} else { |
| $validated = &validate_user($udom, $uname, $upass); |
$validated = &validate_user($udom, $uname, $upass); |
| } |
} |
|
Line 1812 sub change_password_handler {
|
Line 1847 sub change_password_handler {
|
| $salt=substr($salt,6,2); |
$salt=substr($salt,6,2); |
| my $ncpass=crypt($npass,$salt); |
my $ncpass=crypt($npass,$salt); |
| if(&rewrite_password_file($udom, $uname, "internal:$ncpass")) { |
if(&rewrite_password_file($udom, $uname, "internal:$ncpass")) { |
| &logthis("Result of password change for " |
my $msg="Result of password change for $uname: pwchange_success"; |
| ."$uname: pwchange_success"); |
if ($lonhost) { |
| |
$msg .= " - request originated from: $lonhost"; |
| |
} |
| |
&logthis($msg); |
| &Reply($client, "ok\n", $userinput); |
&Reply($client, "ok\n", $userinput); |
| } else { |
} else { |
| &logthis("Unable to open $uname passwd " |
&logthis("Unable to open $uname passwd " |
|
Line 1834 sub change_password_handler {
|
Line 1872 sub change_password_handler {
|
| } |
} |
| |
|
| } else { |
} else { |
| &Failure( $client, "non_authorized\n", $userinput); |
if ($failure eq '') { |
| |
$failure = 'non_authorized'; |
| |
} |
| |
&Failure( $client, "$failure\n", $userinput); |
| } |
} |
| |
|
| return 1; |
return 1; |
|
Line 3081 sub dump_with_regexp {
|
Line 3122 sub dump_with_regexp {
|
| my $qresult=''; |
my $qresult=''; |
| my $count=0; |
my $count=0; |
| while (my ($key,$value) = each(%$hashref)) { |
while (my ($key,$value) = each(%$hashref)) { |
| |
if ($namespace eq 'roles') { |
| |
if ($key =~ /^($LONCAPA::match_domain)_($LONCAPA::match_community)_(cc|co|in|ta|ep|ad|st|cr)/) { |
| |
if ($clientversion =~ /^(\d+)\.(\d+)$/) { |
| |
my $major = $1; |
| |
my $minor = $2; |
| |
next if (($major < 2) || (($major == 2) && ($minor < 10))); |
| |
} |
| |
} |
| |
} |
| if ($regexp eq '.') { |
if ($regexp eq '.') { |
| $count++; |
$count++; |
| if (defined($range) && $count >= $end) { last; } |
if (defined($range) && $count >= $end) { last; } |
|
Line 3645 sub put_course_id_hash_handler {
|
Line 3695 sub put_course_id_hash_handler {
|
| # will be returned. Pre-2.2.0 legacy entries from |
# will be returned. Pre-2.2.0 legacy entries from |
| # nohist_courseiddump will only contain usernames. |
# nohist_courseiddump will only contain usernames. |
| # type - optional parameter for selection |
# type - optional parameter for selection |
| # regexp_ok - if true, allow the supplied institutional code |
# regexp_ok - if 1 or -1 allow the supplied institutional code |
| # filter to behave as a regular expression. |
# filter to behave as a regular expression: |
| |
# 1 will not exclude the course if the instcode matches the RE |
| |
# -1 will exclude the course if the instcode matches the RE |
| # rtn_as_hash - whether to return the information available for |
# rtn_as_hash - whether to return the information available for |
| # each matched item as a frozen hash of all |
# each matched item as a frozen hash of all |
| # key, value pairs in the item's hash, or as a |
# key, value pairs in the item's hash, or as a |
|
Line 3662 sub put_course_id_hash_handler {
|
Line 3714 sub put_course_id_hash_handler {
|
| # caller - if set to 'coursecatalog', courses set to be hidden |
# caller - if set to 'coursecatalog', courses set to be hidden |
| # from course catalog will be excluded from results (unless |
# from course catalog will be excluded from results (unless |
| # overridden by "showhidden". |
# overridden by "showhidden". |
| |
# cloner - escaped username:domain of course cloner (if picking course to |
| |
# clone). |
| |
# cc_clone_list - escaped comma separated list of courses for which |
| |
# course cloner has active CC role (and so can clone |
| |
# automatically). |
| |
# cloneonly - filter by courses for which cloner has rights to clone. |
| |
# createdbefore - include courses for which creation date preceeded this date. |
| |
# createdafter - include courses for which creation date followed this date. |
| |
# creationcontext - include courses created in specified context |
| # |
# |
| # $client - The socket open on the client. |
# $client - The socket open on the client. |
| # Returns: |
# Returns: |
|
Line 3674 sub dump_course_id_handler {
|
Line 3735 sub dump_course_id_handler {
|
| |
|
| my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter, |
my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter, |
| $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden, |
$typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden, |
| $caller) =split(/:/,$tail); |
$caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter, |
| |
$creationcontext) =split(/:/,$tail); |
| my $now = time; |
my $now = time; |
| |
my ($cloneruname,$clonerudom,%cc_clone); |
| if (defined($description)) { |
if (defined($description)) { |
| $description=&unescape($description); |
$description=&unescape($description); |
| } else { |
} else { |
|
Line 3718 sub dump_course_id_handler {
|
Line 3781 sub dump_course_id_handler {
|
| if (defined($catfilter)) { |
if (defined($catfilter)) { |
| $catfilter=&unescape($catfilter); |
$catfilter=&unescape($catfilter); |
| } |
} |
| |
if (defined($cloner)) { |
| |
$cloner = &unescape($cloner); |
| |
($cloneruname,$clonerudom) = ($cloner =~ /^($LONCAPA::match_username):($LONCAPA::match_domain)$/); |
| |
} |
| |
if (defined($cc_clone_list)) { |
| |
$cc_clone_list = &unescape($cc_clone_list); |
| |
my @cc_cloners = split('&',$cc_clone_list); |
| |
foreach my $cid (@cc_cloners) { |
| |
my ($clonedom,$clonenum) = split(':',$cid); |
| |
next if ($clonedom ne $udom); |
| |
$cc_clone{$clonedom.'_'.$clonenum} = 1; |
| |
} |
| |
} |
| |
if ($createdbefore ne '') { |
| |
$createdbefore = &unescape($createdbefore); |
| |
} else { |
| |
$createdbefore = 0; |
| |
} |
| |
if ($createdafter ne '') { |
| |
$createdafter = &unescape($createdafter); |
| |
} else { |
| |
$createdafter = 0; |
| |
} |
| |
if ($creationcontext ne '') { |
| |
$creationcontext = &unescape($creationcontext); |
| |
} else { |
| |
$creationcontext = '.'; |
| |
} |
| |
|
| my $unpack = 1; |
my $unpack = 1; |
| if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' && |
if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' && |
| $typefilter eq '.') { |
$typefilter eq '.') { |
|
Line 3729 sub dump_course_id_handler {
|
Line 3821 sub dump_course_id_handler {
|
| if ($hashref) { |
if ($hashref) { |
| while (my ($key,$value) = each(%$hashref)) { |
while (my ($key,$value) = each(%$hashref)) { |
| my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val, |
my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val, |
| %unesc_val,$selfenroll_end,$selfenroll_types); |
%unesc_val,$selfenroll_end,$selfenroll_types,$created, |
| |
$context); |
| $unesc_key = &unescape($key); |
$unesc_key = &unescape($key); |
| if ($unesc_key =~ /^lasttime:/) { |
if ($unesc_key =~ /^lasttime:/) { |
| next; |
next; |
|
Line 3740 sub dump_course_id_handler {
|
Line 3833 sub dump_course_id_handler {
|
| $lasttime = $hashref->{$lasttime_key}; |
$lasttime = $hashref->{$lasttime_key}; |
| next if ($lasttime<$since); |
next if ($lasttime<$since); |
| } |
} |
| |
my ($canclone,$valchange); |
| my $items = &Apache::lonnet::thaw_unescape($value); |
my $items = &Apache::lonnet::thaw_unescape($value); |
| if (ref($items) eq 'HASH') { |
if (ref($items) eq 'HASH') { |
| |
if ($hashref->{$lasttime_key} eq '') { |
| |
next if ($since > 1); |
| |
} |
| $is_hash = 1; |
$is_hash = 1; |
| |
if (defined($clonerudom)) { |
| |
if ($items->{'cloners'}) { |
| |
my @cloneable = split(',',$items->{'cloners'}); |
| |
if (@cloneable) { |
| |
if (grep(/^\*$/,@cloneable)) { |
| |
$canclone = 1; |
| |
} elsif (grep(/^\*:\Q$clonerudom\E$/,@cloneable)) { |
| |
$canclone = 1; |
| |
} elsif (grep(/^\Q$cloneruname\E:\Q$clonerudom\E$/,@cloneable)) { |
| |
$canclone = 1; |
| |
} |
| |
} |
| |
unless ($canclone) { |
| |
if ($cloneruname ne '' && $clonerudom ne '') { |
| |
if ($cc_clone{$unesc_key}) { |
| |
$canclone = 1; |
| |
$items->{'cloners'} .= ','.$cloneruname.':'. |
| |
$clonerudom; |
| |
$valchange = 1; |
| |
} |
| |
} |
| |
} |
| |
} elsif (defined($cloneruname)) { |
| |
if ($cc_clone{$unesc_key}) { |
| |
$canclone = 1; |
| |
$items->{'cloners'} = $cloneruname.':'.$clonerudom; |
| |
$valchange = 1; |
| |
} |
| |
} |
| |
} |
| if ($unpack || !$rtn_as_hash) { |
if ($unpack || !$rtn_as_hash) { |
| $unesc_val{'descr'} = $items->{'description'}; |
$unesc_val{'descr'} = $items->{'description'}; |
| $unesc_val{'inst_code'} = $items->{'inst_code'}; |
$unesc_val{'inst_code'} = $items->{'inst_code'}; |
| $unesc_val{'owner'} = $items->{'owner'}; |
$unesc_val{'owner'} = $items->{'owner'}; |
| $unesc_val{'type'} = $items->{'type'}; |
$unesc_val{'type'} = $items->{'type'}; |
| |
$unesc_val{'cloners'} = $items->{'cloners'}; |
| |
$unesc_val{'created'} = $items->{'created'}; |
| |
$unesc_val{'context'} = $items->{'context'}; |
| } |
} |
| $selfenroll_types = $items->{'selfenroll_types'}; |
$selfenroll_types = $items->{'selfenroll_types'}; |
| $selfenroll_end = $items->{'selfenroll_end_date'}; |
$selfenroll_end = $items->{'selfenroll_end_date'}; |
| |
$created = $items->{'created'}; |
| |
$context = $items->{'context'}; |
| if ($selfenrollonly) { |
if ($selfenrollonly) { |
| next if (!$selfenroll_types); |
next if (!$selfenroll_types); |
| if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) { |
if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) { |
| next; |
next; |
| } |
} |
| } |
} |
| |
if ($creationcontext ne '.') { |
| |
next if (($context ne '') && ($context ne $creationcontext)); |
| |
} |
| |
if ($createdbefore > 0) { |
| |
next if (($created eq '') || ($created > $createdbefore)); |
| |
} |
| |
if ($createdafter > 0) { |
| |
next if (($created eq '') || ($created <= $createdafter)); |
| |
} |
| if ($catfilter ne '') { |
if ($catfilter ne '') { |
| next if ($items->{'categories'} eq ''); |
next if ($items->{'categories'} eq ''); |
| my @categories = split('&',$items->{'categories'}); |
my @categories = split('&',$items->{'categories'}); |
|
Line 3778 sub dump_course_id_handler {
|
Line 3919 sub dump_course_id_handler {
|
| } |
} |
| } else { |
} else { |
| next if ($catfilter ne ''); |
next if ($catfilter ne ''); |
| next if ($selfenrollonly); |
next if ($selfenrollonly); |
| |
next if ($createdbefore || $createdafter); |
| |
next if ($creationcontext ne '.'); |
| |
if ((defined($clonerudom)) && (defined($cloneruname))) { |
| |
if ($cc_clone{$unesc_key}) { |
| |
$canclone = 1; |
| |
$val{'cloners'} = &escape($cloneruname.':'.$clonerudom); |
| |
} |
| |
} |
| $is_hash = 0; |
$is_hash = 0; |
| my @courseitems = split(/:/,$value); |
my @courseitems = split(/:/,$value); |
| $lasttime = pop(@courseitems); |
$lasttime = pop(@courseitems); |
|
Line 3787 sub dump_course_id_handler {
|
Line 3936 sub dump_course_id_handler {
|
| } |
} |
| ($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems; |
($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems; |
| } |
} |
| |
if ($cloneonly) { |
| |
next unless ($canclone); |
| |
} |
| my $match = 1; |
my $match = 1; |
| if ($description ne '.') { |
if ($description ne '.') { |
| if (!$is_hash) { |
if (!$is_hash) { |
|
Line 3800 sub dump_course_id_handler {
|
Line 3952 sub dump_course_id_handler {
|
| if (!$is_hash) { |
if (!$is_hash) { |
| $unesc_val{'inst_code'} = &unescape($val{'inst_code'}); |
$unesc_val{'inst_code'} = &unescape($val{'inst_code'}); |
| } |
} |
| if ($regexp_ok) { |
if ($regexp_ok == 1) { |
| if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) { |
if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) { |
| $match = 0; |
$match = 0; |
| } |
} |
| |
} elsif ($regexp_ok == -1) { |
| |
if (eval{$unesc_val{'inst_code'} =~ /$instcodefilter/}) { |
| |
$match = 0; |
| |
} |
| } else { |
} else { |
| if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) { |
if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) { |
| $match = 0; |
$match = 0; |
|
Line 3869 sub dump_course_id_handler {
|
Line 4025 sub dump_course_id_handler {
|
| if ($match == 1) { |
if ($match == 1) { |
| if ($rtn_as_hash) { |
if ($rtn_as_hash) { |
| if ($is_hash) { |
if ($is_hash) { |
| $qresult.=$key.'='.$value.'&'; |
if ($valchange) { |
| |
my $newvalue = &Apache::lonnet::freeze_escape($items); |
| |
$qresult.=$key.'='.$newvalue.'&'; |
| |
} else { |
| |
$qresult.=$key.'='.$value.'&'; |
| |
} |
| } else { |
} else { |
| my %rtnhash = ( 'description' => &unescape($val{'descr'}), |
my %rtnhash = ( 'description' => &unescape($val{'descr'}), |
| 'inst_code' => &unescape($val{'inst_code'}), |
'inst_code' => &unescape($val{'inst_code'}), |
| 'owner' => &unescape($val{'owner'}), |
'owner' => &unescape($val{'owner'}), |
| 'type' => &unescape($val{'type'}), |
'type' => &unescape($val{'type'}), |
| |
'cloners' => &unescape($val{'cloners'}), |
| ); |
); |
| my $items = &Apache::lonnet::freeze_escape(\%rtnhash); |
my $items = &Apache::lonnet::freeze_escape(\%rtnhash); |
| $qresult.=$key.'='.$items.'&'; |
$qresult.=$key.'='.$items.'&'; |
|
Line 3998 sub get_domain_handler {
|
Line 4160 sub get_domain_handler {
|
| } |
} |
| ®ister_handler("getdom", \&get_domain_handler, 0, 1, 0); |
®ister_handler("getdom", \&get_domain_handler, 0, 1, 0); |
| |
|
| |
|
| # |
# |
| # Puts an id to a domains id database. |
# Puts an id to a domains id database. |
| # |
# |
|
Line 4305 sub dump_domainroles_handler {
|
Line 4466 sub dump_domainroles_handler {
|
| $rolesfilter=&unescape($rolesfilter); |
$rolesfilter=&unescape($rolesfilter); |
| @roles = split(/\&/,$rolesfilter); |
@roles = split(/\&/,$rolesfilter); |
| } |
} |
| |
|
| my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT()); |
my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT()); |
| if ($hashref) { |
if ($hashref) { |
| my $qresult = ''; |
my $qresult = ''; |
| while (my ($key,$value) = each(%$hashref)) { |
while (my ($key,$value) = each(%$hashref)) { |
| my $match = 1; |
my $match = 1; |
| my ($start,$end) = split(/:/,&unescape($value)); |
my ($end,$start) = split(/:/,&unescape($value)); |
| my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key)); |
my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key)); |
| unless ($startfilter eq '.' || !defined($startfilter)) { |
unless (@roles < 1) { |
| if ($start >= $startfilter) { |
unless (grep/^\Q$trole\E$/,@roles) { |
| $match = 0; |
$match = 0; |
| |
next; |
| } |
} |
| } |
} |
| unless ($endfilter eq '.' || !defined($endfilter)) { |
unless ($startfilter eq '.' || !defined($startfilter)) { |
| if ($end <= $endfilter) { |
if ((defined($start)) && ($start >= $startfilter)) { |
| $match = 0; |
$match = 0; |
| |
next; |
| } |
} |
| } |
} |
| unless (@roles < 1) { |
unless ($endfilter eq '.' || !defined($endfilter)) { |
| unless (grep/^\Q$trole\E$/,@roles) { |
if ((defined($end)) && (($end > 0) && ($end <= $endfilter))) { |
| $match = 0; |
$match = 0; |
| |
next; |
| } |
} |
| } |
} |
| if ($match == 1) { |
if ($match == 1) { |
|
Line 4612 sub enrollment_enabled_handler {
|
Line 4776 sub enrollment_enabled_handler {
|
| } |
} |
| ®ister_handler("autorun", \&enrollment_enabled_handler, 0, 1, 0); |
®ister_handler("autorun", \&enrollment_enabled_handler, 0, 1, 0); |
| |
|
| |
# |
| |
# Validate an institutional code used for a LON-CAPA course. |
| |
# |
| |
# Formal Parameters: |
| |
# $cmd - The command request that got us dispatched. |
| |
# $tail - The tail of the command. In this case, |
| |
# this is a colon separated set of words that will be split |
| |
# into: |
| |
# $dom - The domain for which the check of |
| |
# institutional course code will occur. |
| |
# |
| |
# $instcode - The institutional code for the course |
| |
# being requested, or validated for rights |
| |
# to request. |
| |
# |
| |
# $owner - The course requestor (who will be the |
| |
# course owner, in the form username:domain |
| |
# |
| |
# $client - Socket open on the client. |
| |
# Returns: |
| |
# 1 - Indicating processing should continue. |
| |
# |
| |
sub validate_instcode_handler { |
| |
my ($cmd, $tail, $client) = @_; |
| |
my $userinput = "$cmd:$tail"; |
| |
my ($dom,$instcode,$owner) = split(/:/, $tail); |
| |
$instcode = &unescape($instcode); |
| |
$owner = &unescape($owner); |
| |
my ($outcome,$description) = |
| |
&localenroll::validate_instcode($dom,$instcode,$owner); |
| |
my $result = &escape($outcome).'&'.&escape($description); |
| |
&Reply($client, \$result, $userinput); |
| |
|
| |
return 1; |
| |
} |
| |
®ister_handler("autovalidateinstcode", \&validate_instcode_handler, 0, 1, 0); |
| |
|
| # Get the official sections for which auto-enrollment is possible. |
# Get the official sections for which auto-enrollment is possible. |
| # Since the admin people won't know about 'unofficial sections' |
# Since the admin people won't know about 'unofficial sections' |
| # we cannot auto-enroll on them. |
# we cannot auto-enroll on them. |
|
Line 4815 sub retrieve_auto_file_handler {
|
Line 5016 sub retrieve_auto_file_handler {
|
| } |
} |
| ®ister_handler("autoretrieve", \&retrieve_auto_file_handler, 0,1,0); |
®ister_handler("autoretrieve", \&retrieve_auto_file_handler, 0,1,0); |
| |
|
| |
sub crsreq_checks_handler { |
| |
my ($cmd, $tail, $client) = @_; |
| |
my $userinput = "$cmd:$tail"; |
| |
my $dom = $tail; |
| |
my $result; |
| |
my @reqtypes = ('official','unofficial','community'); |
| |
eval { |
| |
local($SIG{__DIE__})='DEFAULT'; |
| |
my %validations; |
| |
my $response = &localenroll::crsreq_checks($dom,\@reqtypes, |
| |
\%validations); |
| |
if ($response eq 'ok') { |
| |
foreach my $key (keys(%validations)) { |
| |
$result .= &escape($key).'='.&Apache::lonnet::freeze_escape($validations{$key}).'&'; |
| |
} |
| |
$result =~ s/\&$//; |
| |
} else { |
| |
$result = 'error'; |
| |
} |
| |
}; |
| |
if (!$@) { |
| |
&Reply($client, \$result, $userinput); |
| |
} else { |
| |
&Failure($client,"unknown_cmd\n",$userinput); |
| |
} |
| |
return 1; |
| |
} |
| |
®ister_handler("autocrsreqchecks", \&crsreq_checks_handler, 0, 1, 0); |
| |
|
| |
sub validate_crsreq_handler { |
| |
my ($cmd, $tail, $client) = @_; |
| |
my $userinput = "$cmd:$tail"; |
| |
my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = split(/:/, $tail); |
| |
$instcode = &unescape($instcode); |
| |
$owner = &unescape($owner); |
| |
$crstype = &unescape($crstype); |
| |
$inststatuslist = &unescape($inststatuslist); |
| |
$instcode = &unescape($instcode); |
| |
$instseclist = &unescape($instseclist); |
| |
my $outcome; |
| |
eval { |
| |
local($SIG{__DIE__})='DEFAULT'; |
| |
$outcome = &localenroll::validate_crsreq($dom,$owner,$crstype, |
| |
$inststatuslist,$instcode, |
| |
$instseclist); |
| |
}; |
| |
if (!$@) { |
| |
&Reply($client, \$outcome, $userinput); |
| |
} else { |
| |
&Failure($client,"unknown_cmd\n",$userinput); |
| |
} |
| |
return 1; |
| |
} |
| |
®ister_handler("autocrsreqvalidation", \&validate_crsreq_handler, 0, 1, 0); |
| |
|
| # |
# |
| # Read and retrieve institutional code format (for support form). |
# Read and retrieve institutional code format (for support form). |
| # Formal Parameters: |
# Formal Parameters: |
|
Line 4899 sub get_institutional_defaults_handler {
|
Line 5155 sub get_institutional_defaults_handler {
|
| ®ister_handler("autoinstcodedefaults", |
®ister_handler("autoinstcodedefaults", |
| \&get_institutional_defaults_handler,0,1,0); |
\&get_institutional_defaults_handler,0,1,0); |
| |
|
| |
sub get_possible_instcodes_handler { |
| |
my ($cmd, $tail, $client) = @_; |
| |
my $userinput = "$cmd:$tail"; |
| |
|
| |
my $reply; |
| |
my $cdom = $tail; |
| |
my (@codetitles,%cat_titles,%cat_order,@code_order); |
| |
my $formatreply = &localenroll::possible_instcodes($cdom, |
| |
\@codetitles, |
| |
\%cat_titles, |
| |
\%cat_order, |
| |
\@code_order); |
| |
if ($formatreply eq 'ok') { |
| |
my $result = join('&',map {&escape($_);} (@codetitles)).':'; |
| |
$result .= join('&',map {&escape($_);} (@code_order)).':'; |
| |
foreach my $key (keys(%cat_titles)) { |
| |
$result .= &escape($key).'='.&Apache::lonnet::freeze_escape($cat_titles{$key}).'&'; |
| |
} |
| |
$result =~ s/\&$//; |
| |
$result .= ':'; |
| |
foreach my $key (keys(%cat_order)) { |
| |
$result .= &escape($key).'='.&Apache::lonnet::freeze_escape($cat_order{$key}).'&'; |
| |
} |
| |
$result =~ s/\&$//; |
| |
&Reply($client,\$result,$userinput); |
| |
} else { |
| |
&Reply($client, "format_error\n", $userinput); |
| |
} |
| |
return 1; |
| |
} |
| |
®ister_handler("autopossibleinstcodes", |
| |
\&get_possible_instcodes_handler,0,1,0); |
| |
|
| sub get_institutional_user_rules { |
sub get_institutional_user_rules { |
| my ($cmd, $tail, $client) = @_; |
my ($cmd, $tail, $client) = @_; |
| my $userinput = "$cmd:$tail"; |
my $userinput = "$cmd:$tail"; |
|
Line 5981 sub make_new_child {
|
Line 6270 sub make_new_child {
|
| if ($clientip eq '127.0.0.1') { |
if ($clientip eq '127.0.0.1') { |
| $outsideip=&Apache::lonnet::get_host_ip($perlvar{'lonHostID'}); |
$outsideip=&Apache::lonnet::get_host_ip($perlvar{'lonHostID'}); |
| } |
} |
| |
&ReadManagerTable(); |
| my $clientrec=defined(&Apache::lonnet::get_hosts_from_ip($outsideip)); |
my $clientrec=defined(&Apache::lonnet::get_hosts_from_ip($outsideip)); |
| my $ismanager=($managers{$outsideip} ne undef); |
my $ismanager=($managers{$outsideip} ne undef); |
| $clientname = "[unknonwn]"; |
$clientname = "[unknown]"; |
| if($clientrec) { # Establish client type. |
if($clientrec) { # Establish client type. |
| $ConnectionType = "client"; |
$ConnectionType = "client"; |
| $clientname = (&Apache::lonnet::get_hosts_from_ip($outsideip))[-1]; |
$clientname = (&Apache::lonnet::get_hosts_from_ip($outsideip))[-1]; |
|
Line 6012 sub make_new_child {
|
Line 6301 sub make_new_child {
|
| # |
# |
| # If the remote is attempting a local init... give that a try: |
# If the remote is attempting a local init... give that a try: |
| # |
# |
| my ($i, $inittype) = split(/:/, $remotereq); |
(my $i, my $inittype, $clientversion) = split(/:/, $remotereq); |
| |
|
| # If the connection type is ssl, but I didn't get my |
# If the connection type is ssl, but I didn't get my |
| # certificate files yet, then I'll drop back to |
# certificate files yet, then I'll drop back to |
|
Line 6032 sub make_new_child {
|
Line 6321 sub make_new_child {
|
| } |
} |
| |
|
| if($inittype eq "local") { |
if($inittype eq "local") { |
| |
$clientversion = $perlvar{'lonVersion'}; |
| my $key = LocalConnection($client, $remotereq); |
my $key = LocalConnection($client, $remotereq); |
| if($key) { |
if($key) { |
| Debug("Got local key $key"); |
Debug("Got local key $key"); |
![[BACK]](/icons/back.gif){kind=icon}
Return to lond CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom