--- loncom/lond 2009/08/18 20:08:13 1.422
+++ loncom/lond 2011/01/22 21:10:18 1.470
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.422 2009/08/18 20:08:13 raeburn Exp $
+# $Id: lond,v 1.470 2011/01/22 21:10:18 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -15,6 +15,7 @@
#
# LON-CAPA is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
+
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
@@ -42,7 +43,6 @@ use Crypt::IDEA;
use LWP::UserAgent();
use Digest::MD5 qw(md5_hex);
use GDBM_File;
-use Authen::Krb4;
use Authen::Krb5;
use localauth;
use localenroll;
@@ -59,7 +59,7 @@ my $DEBUG = 0; # Non zero to ena
my $status='';
my $lastlog='';
-my $VERSION='$Revision: 1.422 $'; #' stupid emacs
+my $VERSION='$Revision: 1.470 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid="default";
my $currentdomainid;
@@ -67,6 +67,9 @@ my $currentdomainid;
my $client;
my $clientip; # IP address of client.
my $clientname; # LonCAPA name of client.
+my $clientversion; # LonCAPA version running on client.
+my $clienthomedom; # LonCAPA domain of homeID for client.
+ # primary library server.
my $server;
@@ -975,6 +978,9 @@ sub read_profile {
&GDBM_READER());
if ($hashref) {
my @queries=split(/\&/,$what);
+ if ($namespace eq 'roles') {
+ @queries = map { &unescape($_); } @queries;
+ }
my $qresult='';
for (my $i=0;$i<=$#queries;$i++) {
@@ -1068,7 +1074,7 @@ sub pong_handler {
# Implicit Inputs:
# $currenthostid - Global variable that carries the name of the host
# known as.
-# $clientname - Global variable that carries the name of the hsot we're connected to.
+# $clientname - Global variable that carries the name of the host we're connected to.
# Returns:
# 1 - Ok to continue processing.
# 0 - Program should exit.
@@ -1107,7 +1113,7 @@ sub establish_key_handler {
# Implicit Inputs:
# $currenthostid - Global variable that carries the name of the host
# known as.
-# $clientname - Global variable that carries the name of the hsot we're connected to.
+# $clientname - Global variable that carries the name of the host we're connected to.
# Returns:
# 1 - Ok to continue processing.
# 0 - Program should exit.
@@ -1116,6 +1122,8 @@ sub establish_key_handler {
sub load_handler {
my ($cmd, $tail, $replyfd) = @_;
+
+
# Get the load average from /proc/loadavg and calculate it as a percentage of
# the allowed load limit as set by the perl global variable lonLoadLim
@@ -1144,7 +1152,7 @@ sub load_handler {
# Implicit Inputs:
# $currenthostid - Global variable that carries the name of the host
# known as.
-# $clientname - Global variable that carries the name of the hsot we're connected to.
+# $clientname - Global variable that carries the name of the host we're connected to.
# Returns:
# 1 - Ok to continue processing.
# 0 - Program should exit
@@ -1653,6 +1661,14 @@ sub server_loncaparev_handler {
}
®ister_handler("serverloncaparev", \&server_loncaparev_handler, 0, 1, 0);
+sub server_homeID_handler {
+ my ($cmd,$tail,$client) = @_;
+ my $userinput = "$cmd:$tail";
+ &Reply($client,\$perlvar{'lonHostID'},$userinput);
+ return 1;
+}
+®ister_handler("serverhomeID", \&server_homeID_handler, 0, 1, 0);
+
# Process a reinit request. Reinit requests that either
# lonc or lond be reinitialized so that an updated
# host.tab or domain.tab can be processed.
@@ -1762,15 +1778,49 @@ sub authenticate_handler {
# upass - User's password.
# checkdefauth - Pass to validate_user() to try authentication
# with default auth type(s) if no user account.
+ # clientcancheckhost - Passed by clients with functionality in lonauth.pm
+ # to check if session can be hosted.
- my ($udom, $uname, $upass, $checkdefauth)=split(/:/,$tail);
+ my ($udom, $uname, $upass, $checkdefauth, $clientcancheckhost)=split(/:/,$tail);
&Debug(" Authenticate domain = $udom, user = $uname, password = $upass, checkdefauth = $checkdefauth");
chomp($upass);
$upass=&unescape($upass);
my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth);
if($pwdcorrect) {
- &Reply( $client, "authorized\n", $userinput);
+ my $canhost = 1;
+ unless ($clientcancheckhost) {
+ my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
+ my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
+ my @intdoms;
+ my $internet_names = &Apache::lonnet::get_internet_names($clientname);
+ if (ref($internet_names) eq 'ARRAY') {
+ @intdoms = @{$internet_names};
+ }
+ unless ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) {
+ my ($remote,$hosted);
+ my $remotesession = &get_usersession_config($udom,'remotesession');
+ if (ref($remotesession) eq 'HASH') {
+ $remote = $remotesession->{'remote'}
+ }
+ my $hostedsession = &get_usersession_config($clienthomedom,'hostedsession');
+ if (ref($hostedsession) eq 'HASH') {
+ $hosted = $hostedsession->{'hosted'};
+ }
+ my $loncaparev = $clientversion;
+ if ($loncaparev eq '') {
+ $loncaparev = $Apache::lonnet::loncaparevs{$clientname};
+ }
+ $canhost = &Apache::lonnet::can_host_session($udom,$clientname,
+ $loncaparev,
+ $remote,$hosted);
+ }
+ }
+ if ($canhost) {
+ &Reply( $client, "authorized\n", $userinput);
+ } else {
+ &Reply( $client, "not_allowed_to_host\n", $userinput);
+ }
#
# Bad credentials: Failed to authorize
#
@@ -1815,8 +1865,9 @@ sub change_password_handler {
# npass - New password.
# context - Context in which this was called
# (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);
$npass=&unescape($npass);
@@ -1825,9 +1876,13 @@ sub change_password_handler {
# First require that the user can be authenticated with their
# old password unless context was 'reset_by_email':
- my $validated;
+ my ($validated,$failure);
if ($context eq 'reset_by_email') {
- $validated = 1;
+ if ($lonhost eq '') {
+ $failure = 'invalid_client';
+ } else {
+ $validated = 1;
+ }
} else {
$validated = &validate_user($udom, $uname, $upass);
}
@@ -1841,8 +1896,11 @@ sub change_password_handler {
$salt=substr($salt,6,2);
my $ncpass=crypt($npass,$salt);
if(&rewrite_password_file($udom, $uname, "internal:$ncpass")) {
- &logthis("Result of password change for "
- ."$uname: pwchange_success");
+ my $msg="Result of password change for $uname: pwchange_success";
+ if ($lonhost) {
+ $msg .= " - request originated from: $lonhost";
+ }
+ &logthis($msg);
&Reply($client, "ok\n", $userinput);
} else {
&logthis("Unable to open $uname passwd "
@@ -1863,7 +1921,10 @@ sub change_password_handler {
}
} else {
- &Failure( $client, "non_authorized\n", $userinput);
+ if ($failure eq '') {
+ $failure = 'non_authorized';
+ }
+ &Failure( $client, "$failure\n", $userinput);
}
return 1;
@@ -2050,16 +2111,10 @@ sub is_home_handler {
®ister_handler("home", \&is_home_handler, 0,1,0);
#
-# Process an update request for a resource?? I think what's going on here is
-# that a resource has been modified that we hold a subscription to.
+# Process an update request for a resource.
+# A resource has been modified that we hold a subscription to.
# If the resource is not local, then we must update, or at least invalidate our
# cached copy of the resource.
-# FUTURE WORK:
-# I need to look at this logic carefully. My druthers would be to follow
-# typical caching logic, and simple invalidate the cache, drop any subscription
-# an let the next fetch start the ball rolling again... however that may
-# actually be more difficult than it looks given the complex web of
-# proxy servers.
# Parameters:
# $cmd - The command that got us here.
# $tail - Tail of the command (remaining parameters).
@@ -2083,20 +2138,30 @@ sub update_resource_handler {
my $ownership=ishome($fname);
if ($ownership eq 'not_owner') {
if (-e $fname) {
+ # Delete preview file, if exists
+ unlink("$fname.tmp");
+ # Get usage stats
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);
my $now=time;
my $since=$now-$atime;
+ # If the file has not been used within lonExpire seconds,
+ # unsubscribe from it and delete local copy
if ($since>$perlvar{'lonExpire'}) {
my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname");
&devalidate_meta_cache($fname);
unlink("$fname");
unlink("$fname.meta");
} else {
+ # Yes, this is in active use. Get a fresh copy. Since it might be in
+ # very active use and huge (like a movie), copy it to "in.transfer" filename first.
my $transname="$fname.in.transfer";
my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");
my $response;
- alarm(120);
+# FIXME: cannot replicate files that take more than two minutes to transfer?
+# alarm(120);
+# FIXME: this should use the LWP mechanism, not internal alarms.
+ alarm(1200);
{
my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',"$remoteurl");
@@ -2104,11 +2169,13 @@ sub update_resource_handler {
}
alarm(0);
if ($response->is_error()) {
+# FIXME: we should probably clean up here instead of just whine
unlink($transname);
my $message=$response->status_line;
&logthis("LWP GET: $message for $fname ($remoteurl)");
} else {
if ($remoteurl!~/\.meta$/) {
+# FIXME: isn't there an internal LWP mechanism for this?
alarm(120);
{
my $ua=new LWP::UserAgent;
@@ -2120,6 +2187,7 @@ sub update_resource_handler {
}
alarm(0);
}
+ # we successfully transfered, copy file over to real name
rename($transname,$fname);
&devalidate_meta_cache($fname);
}
@@ -2357,7 +2425,6 @@ sub user_has_session_handler {
my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));
- &logthis("Looking for $udom $uname");
opendir(DIR,$perlvar{'lonIDsDir'});
my $filename;
while ($filename=readdir(DIR)) {
@@ -3088,7 +3155,7 @@ sub dump_with_regexp {
my $userinput = "$cmd:$tail";
- my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail);
+ my ($udom,$uname,$namespace,$regexp,$range,$extra)=split(/:/,$tail);
if (defined($regexp)) {
$regexp=&unescape($regexp);
} else {
@@ -3106,10 +3173,41 @@ sub dump_with_regexp {
}
my $hashref = &tie_user_hash($udom, $uname, $namespace,
&GDBM_READER());
+ my $skipcheck;
if ($hashref) {
my $qresult='';
my $count=0;
+ if ($extra ne '') {
+ $extra = &Apache::lonnet::thaw_unescape($extra);
+ $skipcheck = $extra->{'skipcheck'};
+ }
+ my @ids = &Apache::lonnet::current_machine_ids();
+ my (%homecourses,$major,$minor,$now);
+ if (($namespace eq 'roles') && (!$skipcheck)) {
+ my $loncaparev = $clientversion;
+ if ($loncaparev eq '') {
+ $loncaparev = $Apache::lonnet::loncaparevs{$clientname};
+ }
+ if ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {
+ $major = $1;
+ $minor = $2;
+ }
+ $now = time;
+ }
while (my ($key,$value) = each(%$hashref)) {
+ if ($namespace eq 'roles') {
+ if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)(/?[^_]*)_(cc|co|in|ta|ep|ad|st|cr)$}) {
+ my $cdom = $1;
+ my $cnum = $2;
+ unless ($skipcheck) {
+ my ($role,$end,$start) = split(/\_/,$value);
+ if (!$end || $end > $now) {
+ next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,
+ $minor,\%homecourses,\@ids));
+ }
+ }
+ }
+ }
if ($regexp eq '.') {
$count++;
if (defined($range) && $count >= $end) { last; }
@@ -3126,6 +3224,12 @@ sub dump_with_regexp {
}
}
if (&untie_user_hash($hashref)) {
+ if (($namespace eq 'roles') && (!$skipcheck)) {
+ if (keys(%homecourses) > 0) {
+ $qresult .= &check_homecourses(\%homecourses,$udom,$regexp,$count,
+ $range,$start,$end,$major,$minor);
+ }
+ }
chop($qresult);
&Reply($client, \$qresult, $userinput);
} else {
@@ -3693,12 +3797,18 @@ sub put_course_id_hash_handler {
# caller - if set to 'coursecatalog', courses set to be hidden
# from course catalog will be excluded from results (unless
# overridden by "showhidden".
-# cloner - escaped username:domain of course cloner (if picking course to#
+# 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.
+# 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
+#
+# domcloner - flag to indicate if user can create CCs in course's domain.
+# If so, ability to clone course is automatic.
#
# $client - The socket open on the client.
# Returns:
@@ -3711,7 +3821,8 @@ sub dump_course_id_handler {
my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
$typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,
- $caller,$cloner,$cc_clone_list,$cloneonly) =split(/:/,$tail);
+ $caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,
+ $creationcontext,$domcloner) =split(/:/,$tail);
my $now = time;
my ($cloneruname,$clonerudom,%cc_clone);
if (defined($description)) {
@@ -3769,7 +3880,21 @@ sub dump_course_id_handler {
$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;
if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&
$typefilter eq '.') {
@@ -3781,7 +3906,8 @@ sub dump_course_id_handler {
if ($hashref) {
while (my ($key,$value) = each(%$hashref)) {
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);
if ($unesc_key =~ /^lasttime:/) {
next;
@@ -3795,8 +3921,13 @@ sub dump_course_id_handler {
my ($canclone,$valchange);
my $items = &Apache::lonnet::thaw_unescape($value);
if (ref($items) eq 'HASH') {
+ if ($hashref->{$lasttime_key} eq '') {
+ next if ($since > 1);
+ }
$is_hash = 1;
- if (defined($clonerudom)) {
+ if ($domcloner) {
+ $canclone = 1;
+ } elsif (defined($clonerudom)) {
if ($items->{'cloners'}) {
my @cloneable = split(',',$items->{'cloners'});
if (@cloneable) {
@@ -3824,6 +3955,19 @@ sub dump_course_id_handler {
$items->{'cloners'} = $cloneruname.':'.$clonerudom;
$valchange = 1;
}
+ unless ($canclone) {
+ if ($items->{'owner'} =~ /:/) {
+ if ($items->{'owner'} eq $cloner) {
+ $canclone = 1;
+ }
+ } elsif ($cloner eq $items->{'owner'}.':'.$udom) {
+ $canclone = 1;
+ }
+ if ($canclone) {
+ $items->{'cloners'} = $cloneruname.':'.$clonerudom;
+ $valchange = 1;
+ }
+ }
}
}
if ($unpack || !$rtn_as_hash) {
@@ -3832,15 +3976,28 @@ sub dump_course_id_handler {
$unesc_val{'owner'} = $items->{'owner'};
$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_end = $items->{'selfenroll_end_date'};
+ $created = $items->{'created'};
+ $context = $items->{'context'};
if ($selfenrollonly) {
next if (!$selfenroll_types);
if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) {
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 '') {
next if ($items->{'categories'} eq '');
my @categories = split('&',$items->{'categories'});
@@ -3863,6 +4020,8 @@ sub dump_course_id_handler {
} else {
next if ($catfilter ne '');
next if ($selfenrollonly);
+ next if ($createdbefore || $createdafter);
+ next if ($creationcontext ne '.');
if ((defined($clonerudom)) && (defined($cloneruname))) {
if ($cc_clone{$unesc_key}) {
$canclone = 1;
@@ -4009,6 +4168,53 @@ sub dump_course_id_handler {
}
®ister_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);
+sub course_lastaccess_handler {
+ my ($cmd, $tail, $client) = @_;
+ my $userinput = "$cmd:$tail";
+ my ($cdom,$cnum) = split(':',$tail);
+ my (%lastaccess,$qresult);
+ my $hashref = &tie_domain_hash($cdom, "nohist_courseids", &GDBM_WRCREAT());
+ if ($hashref) {
+ while (my ($key,$value) = each(%$hashref)) {
+ my ($unesc_key,$lasttime);
+ $unesc_key = &unescape($key);
+ if ($cnum) {
+ next unless ($unesc_key =~ /\Q$cdom\E_\Q$cnum\E$/);
+ }
+ if ($unesc_key =~ /^lasttime:($LONCAPA::match_domain\_$LONCAPA::match_courseid)/) {
+ $lastaccess{$1} = $value;
+ } else {
+ my $items = &Apache::lonnet::thaw_unescape($value);
+ if (ref($items) eq 'HASH') {
+ unless ($lastaccess{$unesc_key}) {
+ $lastaccess{$unesc_key} = '';
+ }
+ } else {
+ my @courseitems = split(':',$value);
+ $lastaccess{$unesc_key} = pop(@courseitems);
+ }
+ }
+ }
+ foreach my $cid (sort(keys(%lastaccess))) {
+ $qresult.=&escape($cid).'='.$lastaccess{$cid}.'&';
+ }
+ if (&untie_domain_hash($hashref)) {
+ if ($qresult) {
+ chop($qresult);
+ }
+ &Reply($client, \$qresult, $userinput);
+ } else {
+ &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
+ "while attempting lastacourseaccess\n", $userinput);
+ }
+ } else {
+ &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
+ "while attempting lastcourseaccess\n", $userinput);
+ }
+ return 1;
+}
+®ister_handler("courselastaccess",\&course_lastaccess_handler, 0, 1, 0);
+
#
# Puts an unencrypted entry in a namespace db file at the domain level
#
@@ -4052,60 +4258,6 @@ sub put_domain_handler {
}
®ister_handler("putdom", \&put_domain_handler, 0, 1, 0);
-#
-# Puts a piece of new data in a namespace db file at the domain level
-# returns error if key already exists
-#
-# Parameters:
-# $cmd - The command that got us here.
-# $tail - Tail of the command (remaining parameters).
-# $client - File descriptor connected to client.
-# Returns
-# 0 - Requested to exit, caller should shut down.
-# 1 - Continue processing.
-# Side effects:
-# reply is written to $client.
-#
-sub newput_domain_handler {
- my ($cmd, $tail, $client) = @_;
-
- my $userinput = "$cmd:$tail";
-
- my ($udom,$namespace,$what) =split(/:/,$tail,3);
- chomp($what);
- my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_WRCREAT(),
- "N", $what);
- if(!$hashref) {
- &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
- "while attempting newputdom\n", $userinput);
- return 1;
- }
-
- my @pairs=split(/\&/,$what);
- foreach my $pair (@pairs) {
- my ($key,$value)=split(/=/,$pair);
- if (exists($hashref->{$key})) {
- &Failure($client, "key_exists: ".$key."\n",$userinput);
- return 1;
- }
- }
-
- foreach my $pair (@pairs) {
- my ($key,$value)=split(/=/,$pair);
- $hashref->{$key}=$value;
- }
-
- if (&untie_domain_hash($hashref)) {
- &Reply( $client, "ok\n", $userinput);
- } else {
- &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
- "while attempting newputdom\n",
- $userinput);
- }
- return 1;
-}
-®ister_handler("newputdom", \&newput_domain_handler, 0, 1, 0);
-
# Unencrypted get from the namespace database file at the domain level.
# This function retrieves a keyed item from a specific named database in the
# domain directory.
@@ -4128,6 +4280,7 @@ sub newput_domain_handler {
sub get_domain_handler {
my ($cmd, $tail, $client) = @_;
+
my $userinput = "$client:$tail";
my ($udom,$namespace,$what)=split(/:/,$tail,3);
@@ -4156,50 +4309,6 @@ sub get_domain_handler {
®ister_handler("getdom", \&get_domain_handler, 0, 1, 0);
#
-# Deletes a key in a user profile database.
-#
-# Parameters:
-# $cmd - Command keyword (deldom).
-# $tail - Command tail. IN this case a colon
-# separated list containing:
-# the domain to which the database file belongs;
-# the namespace (name of the database file);
-# & separated list of keys to delete.
-# $client - File open on client socket.
-# Returns:
-# 1 - Continue processing
-# 0 - Exit server.
-#
-#
-sub delete_domain_entry {
- my ($cmd, $tail, $client) = @_;
-
- my $userinput = "cmd:$tail";
-
- my ($udom,$namespace,$what) = split(/:/,$tail);
- chomp($what);
- my $hashref = &tie_domain_hash($udom, $namespace, &GDBM_WRCREAT(),
- "D",$what);
- if ($hashref) {
- my @keys=split(/\&/,$what);
- foreach my $key (@keys) {
- delete($hashref->{$key});
- }
- if (&untie_user_hash($hashref)) {
- &Reply($client, "ok\n", $userinput);
- } else {
- &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
- "while attempting deldom\n", $userinput);
- }
- } else {
- &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
- "while attempting deldom\n", $userinput);
- }
- return 1;
-}
-®ister_handler("deldom", \&delete_domain_entry, 0, 1, 0);
-
-#
# Puts an id to a domains id database.
#
# Parameters:
@@ -4296,60 +4405,6 @@ sub get_id_handler {
}
®ister_handler("idget", \&get_id_handler, 0, 1, 0);
-sub dump_dom_with_regexp {
- my ($cmd, $tail, $client) = @_;
- my $userinput = "$cmd:$tail";
- my ($udom,$namespace,$regexp,$range)=split(/:/,$tail);
- if (defined($regexp)) {
- $regexp=&unescape($regexp);
- } else {
- $regexp='.';
- }
- my ($start,$end);
- if (defined($range)) {
- if ($range =~/^(\d+)\-(\d+)$/) {
- ($start,$end) = ($1,$2);
- } elsif ($range =~/^(\d+)$/) {
- ($start,$end) = (0,$1);
- } else {
- undef($range);
- }
- }
- my $hashref = &tie_domain_hash($udom, $namespace, &GDBM_READER());
- if ($hashref) {
- my $qresult='';
- my $count=0;
- while (my ($key,$value) = each(%$hashref)) {
- if ($regexp eq '.') {
- $count++;
- if (defined($range) && $count >= $end) { last; }
- if (defined($range) && $count < $start) { next; }
- $qresult.=$key.'='.$value.'&';
- } else {
- my $unescapeKey = &unescape($key);
- if (eval('$unescapeKey=~/$regexp/')) {
- $count++;
- if (defined($range) && $count >= $end) { last; }
- if (defined($range) && $count < $start) { next; }
- $qresult.="$key=$value&";
- }
- }
- }
- if (&untie_user_hash($hashref)) {
- chop($qresult);
- &Reply($client, \$qresult, $userinput);
- } else {
- &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
- "while attempting dump\n", $userinput);
- }
- } else {
- &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
- "while attempting dump\n", $userinput);
- }
- return 1;
-}
-®ister_handler("dumpdom", \&dump_dom_with_regexp, 0, 1, 0);
-
#
# Puts broadcast e-mail sent by Domain Coordinator in nohist_dcmail database
#
@@ -4370,7 +4425,8 @@ sub dump_dom_with_regexp {
sub put_dcmail_handler {
my ($cmd,$tail,$client) = @_;
my $userinput = "$cmd:$tail";
-
+
+
my ($udom,$what)=split(/:/,$tail);
chomp($what);
my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
@@ -4634,7 +4690,7 @@ sub tmp_put_handler {
}
my ($id,$store);
$tmpsnum++;
- if ($context eq 'resetpw') {
+ if (($context eq 'resetpw') || ($context eq 'createaccount')) {
$id = &md5_hex(&md5_hex(time.{}.rand().$$));
} else {
$id = $$.'_'.$clientip.'_'.$tmpsnum;
@@ -4870,17 +4926,23 @@ sub enrollment_enabled_handler {
®ister_handler("autorun", \&enrollment_enabled_handler, 0, 1, 0);
#
-# Validate an institutional code use for a LON-CAPA course.
+# 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:
-# $inst_course_id - The institutional cod3 from the
-# institutions point of view.
-# $cdom - The domain from the institutions
-# point of view.
+# $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.
@@ -4888,14 +4950,13 @@ sub enrollment_enabled_handler {
sub validate_instcode_handler {
my ($cmd, $tail, $client) = @_;
my $userinput = "$cmd:$tail";
- my ($dom,$instcode,$owner,$inststatus,$instseclist) = split(/:/, $tail);
+ my ($dom,$instcode,$owner) = split(/:/, $tail);
$instcode = &unescape($instcode);
$owner = &unescape($owner);
- $inststatus = &unescape($inststatus);
- $instseclist = &unescape($instseclist);
- my $outcome=&localenroll::validate_instcode($dom,$instcode,$owner,
- $inststatus,$instseclist);
- &Reply($client, \$outcome, $userinput);
+ my ($outcome,$description) =
+ &localenroll::validate_instcode($dom,$instcode,$owner);
+ my $result = &escape($outcome).'&'.&escape($description);
+ &Reply($client, \$result, $userinput);
return 1;
}
@@ -4947,10 +5008,11 @@ sub get_sections_handler {
sub validate_course_owner_handler {
my ($cmd, $tail, $client) = @_;
my $userinput = "$cmd:$tail";
- my ($inst_course_id, $owner, $cdom) = split(/:/, $tail);
-
+ my ($inst_course_id, $owner, $cdom, $coowners) = split(/:/, $tail);
+
$owner = &unescape($owner);
- my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
+ $coowners = &unescape($coowners);
+ my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom,$coowners);
&Reply($client, \$outcome, $userinput);
@@ -5104,6 +5166,61 @@ sub retrieve_auto_file_handler {
}
®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).
# Formal Parameters:
@@ -5883,7 +6000,7 @@ if (-e $pidfile) {
$server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
Type => SOCK_STREAM,
Proto => 'tcp',
- Reuse => 1,
+ ReuseAddr => 1,
Listen => 10 )
or die "making socket: $@\n";
@@ -6121,7 +6238,7 @@ sub logstatus {
sub initnewstatus {
my $docdir=$perlvar{'lonDocRoot'};
my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
- my $now=time;
+ my $now=time();
my $local=localtime($now);
print $fh "LOND status $local - parent $$\n\n";
opendir(DIR,"$docdir/lon-status/londchld");
@@ -6210,6 +6327,7 @@ $SIG{USR2} = \&UpdateHosts;
# Read the host hashes:
&Apache::lonnet::load_hosts_tab();
+my %iphost = &Apache::lonnet::get_iphost(1);
my $dist=`$perlvar{'lonDaemons'}/distprobe`;
@@ -6270,6 +6388,7 @@ sub make_new_child {
or die "Can't unblock SIGINT for fork: $!\n";
$children{$pid} = $clientip;
&status('Started child '.$pid);
+ close($client);
return;
} else {
# Child can *not* return from this subroutine.
@@ -6278,6 +6397,13 @@ sub make_new_child {
#don't get intercepted
$SIG{USR1}= \&logstatus;
$SIG{ALRM}= \&timeout;
+ #
+ # Block sigpipe as it gets thrownon socket disconnect and we want to
+ # deal with that as a read faiure instead.
+ #
+ my $blockset = POSIX::SigSet->new(SIGPIPE);
+ sigprocmask(SIG_BLOCK, $blockset);
+
$lastlog='Forked ';
$status='Forked';
@@ -6306,7 +6432,7 @@ sub make_new_child {
&ReadManagerTable();
my $clientrec=defined(&Apache::lonnet::get_hosts_from_ip($outsideip));
my $ismanager=($managers{$outsideip} ne undef);
- $clientname = "[unknonwn]";
+ $clientname = "[unknown]";
if($clientrec) { # Establish client type.
$ConnectionType = "client";
$clientname = (&Apache::lonnet::get_hosts_from_ip($outsideip))[-1];
@@ -6334,7 +6460,7 @@ sub make_new_child {
#
# 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
# certificate files yet, then I'll drop back to
@@ -6354,6 +6480,7 @@ sub make_new_child {
}
if($inittype eq "local") {
+ $clientversion = $perlvar{'lonVersion'};
my $key = LocalConnection($client, $remotereq);
if($key) {
Debug("Got local key $key");
@@ -6361,7 +6488,7 @@ sub make_new_child {
my $cipherkey = pack("H32", $key);
$cipher = new IDEA($cipherkey);
print $client "ok:local\n";
- &logthis('<font color="green"'
+ &logthis('<font color="green">'
. "Successful local authentication </font>");
$keymode = "local"
} else {
@@ -6425,6 +6552,9 @@ sub make_new_child {
# ------------------------------------------------------------ Process requests
my $keep_going = 1;
my $user_input;
+ my $clienthost = &Apache::lonnet::hostname($clientname);
+ my $clientserverhomeID = &Apache::lonnet::get_server_homeID($clienthost);
+ $clienthomedom = &Apache::lonnet::host_domain($clientserverhomeID);
while(($user_input = get_request) && $keep_going) {
alarm(120);
Debug("Main: Got $user_input\n");
@@ -6583,9 +6713,7 @@ sub rewrite_password_file {
# Returns the authorization type or nouser if there is no such user.
#
-sub get_auth_type
-{
-
+sub get_auth_type {
my ($domain, $user) = @_;
Debug("get_auth_type( $domain, $user ) \n");
@@ -6680,54 +6808,24 @@ sub validate_user {
} else {
$validated = 0;
}
- }
- elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.
- if(! ($password =~ /$null/) ) {
- my $k4error = &Authen::Krb4::get_pw_in_tkt($user,
- "",
- $contentpwd,,
- 'krbtgt',
- $contentpwd,
- 1,
- $password);
- if(!$k4error) {
- $validated = 1;
- } else {
- $validated = 0;
- &logthis('krb4: '.$user.', '.$contentpwd.', '.
- &Authen::Krb4::get_err_txt($Authen::Krb4::error));
- }
- } else {
- $validated = 0; # Password has a match with null.
- }
+ } elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.
+ my $checkwithkrb5 = 0;
+ if ($dist =~/^fedora(\d+)$/) {
+ if ($1 > 11) {
+ $checkwithkrb5 = 1;
+ }
+ } elsif ($dist =~ /^suse([\d.]+)$/) {
+ if ($1 > 11.1) {
+ $checkwithkrb5 = 1;
+ }
+ }
+ if ($checkwithkrb5) {
+ $validated = &krb5_authen($password,$null,$user,$contentpwd);
+ } else {
+ $validated = &krb4_authen($password,$null,$user,$contentpwd);
+ }
} elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.
- if(!($password =~ /$null/)) { # Null password not allowed.
- my $krbclient = &Authen::Krb5::parse_name($user.'@'
- .$contentpwd);
- my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
- my $krbserver = &Authen::Krb5::parse_name($krbservice);
- my $credentials= &Authen::Krb5::cc_default();
- $credentials->initialize(&Authen::Krb5::parse_name($user.'@'
- .$contentpwd));
- my $krbreturn;
- if (exists(&Authen::Krb5::get_init_creds_password)) {
- $krbreturn =
- &Authen::Krb5::get_init_creds_password($krbclient,$password,
- $krbservice);
- $validated = (ref($krbreturn) eq 'Authen::Krb5::Creds');
- } else {
- $krbreturn =
- &Authen::Krb5::get_in_tkt_with_password($krbclient,$krbserver,
- $password,$credentials);
- $validated = ($krbreturn == 1);
- }
- if (!$validated) {
- &logthis('krb5: '.$user.', '.$contentpwd.', '.
- &Authen::Krb5::error());
- }
- } else {
- $validated = 0;
- }
+ $validated = &krb5_authen($password,$null,$user,$contentpwd);
} elsif ($howpwd eq "localauth") {
# Authenticate via installation specific authentcation method:
$validated = &localauth::localauth($user,
@@ -6758,6 +6856,65 @@ sub validate_user {
return $validated;
}
+sub krb4_authen {
+ my ($password,$null,$user,$contentpwd) = @_;
+ my $validated = 0;
+ if (!($password =~ /$null/) ) { # Null password not allowed.
+ eval {
+ require Authen::Krb4;
+ };
+ if (!$@) {
+ my $k4error = &Authen::Krb4::get_pw_in_tkt($user,
+ "",
+ $contentpwd,,
+ 'krbtgt',
+ $contentpwd,
+ 1,
+ $password);
+ if(!$k4error) {
+ $validated = 1;
+ } else {
+ $validated = 0;
+ &logthis('krb4: '.$user.', '.$contentpwd.', '.
+ &Authen::Krb4::get_err_txt($Authen::Krb4::error));
+ }
+ } else {
+ $validated = krb5_authen($password,$null,$user,$contentpwd);
+ }
+ }
+ return $validated;
+}
+
+sub krb5_authen {
+ my ($password,$null,$user,$contentpwd) = @_;
+ my $validated = 0;
+ if(!($password =~ /$null/)) { # Null password not allowed.
+ my $krbclient = &Authen::Krb5::parse_name($user.'@'
+ .$contentpwd);
+ my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
+ my $krbserver = &Authen::Krb5::parse_name($krbservice);
+ my $credentials= &Authen::Krb5::cc_default();
+ $credentials->initialize(&Authen::Krb5::parse_name($user.'@'
+ .$contentpwd));
+ my $krbreturn;
+ if (exists(&Authen::Krb5::get_init_creds_password)) {
+ $krbreturn =
+ &Authen::Krb5::get_init_creds_password($krbclient,$password,
+ $krbservice);
+ $validated = (ref($krbreturn) eq 'Authen::Krb5::Creds');
+ } else {
+ $krbreturn =
+ &Authen::Krb5::get_in_tkt_with_password($krbclient,$krbserver,
+ $password,$credentials);
+ $validated = ($krbreturn == 1);
+ }
+ if (!$validated) {
+ &logthis('krb5: '.$user.', '.$contentpwd.', '.
+ &Authen::Krb5::error());
+ }
+ }
+ return $validated;
+}
sub addline {
my ($fname,$hostid,$ip,$newline)=@_;
@@ -7128,7 +7285,7 @@ sub sethost {
eq &Apache::lonnet::get_host_ip($hostid)) {
$currenthostid =$hostid;
$currentdomainid=&Apache::lonnet::host_domain($hostid);
- &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
+# &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
} else {
&logthis("Requested host id $hostid not an alias of ".
$perlvar{'lonHostID'}." refusing connection");
@@ -7143,6 +7300,182 @@ sub version {
return "version:$VERSION";
}
+sub get_usersession_config {
+ my ($dom,$name) = @_;
+ my ($usersessionconf,$cached)=&Apache::lonnet::is_cached_new($name,$dom);
+ if (defined($cached)) {
+ return $usersessionconf;
+ } else {
+ my %domconfig = &Apache::lonnet::get_dom('configuration',['usersessions'],$dom);
+ if (ref($domconfig{'usersessions'}) eq 'HASH') {
+ &Apache::lonnet::do_cache_new($name,$dom,$domconfig{'usersessions'},3600);
+ return $domconfig{'usersessions'};
+ }
+ }
+ return;
+}
+
+sub releasereqd_check {
+ my ($cnum,$cdom,$key,$value,$major,$minor,$homecourses,$ids) = @_;
+ my $home = &Apache::lonnet::homeserver($cnum,$cdom);
+ return if ($home eq 'no_host');
+ my ($reqdmajor,$reqdminor,$displayrole);
+ if ($cnum =~ /$LONCAPA::match_community/) {
+ if ($major eq '' && $minor eq '') {
+ return unless ((ref($ids) eq 'ARRAY') &&
+ (grep(/^\Q$home\E$/,@{$ids})));
+ } else {
+ $reqdmajor = 2;
+ $reqdminor = 9;
+ return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
+ }
+ }
+ my $hashid = $cdom.':'.$cnum;
+ my ($courseinfo,$cached) =
+ &Apache::lonnet::is_cached_new('courseinfo',$hashid);
+ if (defined($cached)) {
+ if (ref($courseinfo) eq 'HASH') {
+ if (exists($courseinfo->{'releaserequired'})) {
+ my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
+ return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
+ }
+ }
+ } else {
+ if (ref($ids) eq 'ARRAY') {
+ if (grep(/^\Q$home\E$/,@{$ids})) {
+ if (ref($homecourses) eq 'HASH') {
+ if (ref($homecourses->{$hashid}) eq 'ARRAY') {
+ push(@{$homecourses->{$hashid}},{$key=>$value});
+ } else {
+ $homecourses->{$hashid} = [{$key=>$value}];
+ }
+ }
+ return;
+ }
+ }
+ my $courseinfo = &get_courseinfo_hash($cnum,$cdom,$home);
+ if (ref($courseinfo) eq 'HASH') {
+ if (exists($courseinfo->{'releaserequired'})) {
+ my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
+ return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
+ }
+ } else {
+ return;
+ }
+ }
+ return 1;
+}
+
+sub get_courseinfo_hash {
+ my ($cnum,$cdom,$home) = @_;
+ my %info;
+ eval {
+ local($SIG{ALRM}) = sub { die "timeout\n"; };
+ local($SIG{__DIE__})='DEFAULT';
+ alarm(3);
+ %info = &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,1,[$home],'.');
+ alarm(0);
+ };
+ if ($@) {
+ if ($@ eq "timeout\n") {
+ &logthis("<font color='blue'>WARNING courseiddump for $cnum:$cdom from $home timedout</font>");
+ } else {
+ &logthis("<font color='yellow'>WARNING unexpected error during eval of call for courseiddump from $home</font>");
+ }
+ } else {
+ if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') {
+ my $hashid = $cdom.':'.$cnum;
+ return &Apache::lonnet::do_cache_new('courseinfo',$hashid,$info{$cdom.'_'.$cnum},600);
+ }
+ }
+ return;
+}
+
+sub check_homecourses {
+ my ($homecourses,$udom,$regexp,$count,$range,$start,$end,$major,$minor) = @_;
+ my ($result,%addtocache);
+ my $yesterday = time - 24*3600;
+ if (ref($homecourses) eq 'HASH') {
+ my (%okcourses,%courseinfo,%recent);
+ my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
+ if ($hashref) {
+ while (my ($key,$value) = each(%$hashref)) {
+ my $unesc_key = &unescape($key);
+ if ($unesc_key =~ /^lasttime:(\w+)$/) {
+ my $cid = $1;
+ $cid =~ s/_/:/;
+ if ($value > $yesterday ) {
+ $recent{$cid} = 1;
+ }
+ next;
+ }
+ my $items = &Apache::lonnet::thaw_unescape($value);
+ if (ref($items) eq 'HASH') {
+ my $hashid = $unesc_key;
+ $hashid =~ s/_/:/;
+ $courseinfo{$hashid} = $items;
+ if (ref($homecourses->{$hashid}) eq 'ARRAY') {
+ my ($reqdmajor,$reqdminor) = split(/\./,$items->{'releaserequired'});
+ if (&useable_role($reqdmajor,$reqdminor,$major,$minor)) {
+ $okcourses{$hashid} = 1;
+ }
+ }
+ }
+ }
+ unless (&untie_domain_hash($hashref)) {
+ &logthis('Failed to untie tied hash for nohist_courseids.db');
+ }
+ } else {
+ &logthis('Failed to tie hash for nohist_courseids.db');
+ return;
+ }
+ foreach my $hashid (keys(%recent)) {
+ my ($result,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid);
+ unless ($cached) {
+ &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
+ }
+ }
+ foreach my $hashid (keys(%{$homecourses})) {
+ next if ($recent{$hashid});
+ &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
+ }
+ foreach my $hashid (keys(%okcourses)) {
+ if (ref($homecourses->{$hashid}) eq 'ARRAY') {
+ foreach my $role (@{$homecourses->{$hashid}}) {
+ if (ref($role) eq 'HASH') {
+ while (my ($key,$value) = each(%{$role})) {
+ if ($regexp eq '.') {
+ $count++;
+ if (defined($range) && $count >= $end) { last; }
+ if (defined($range) && $count < $start) { next; }
+ $result.=$key.'='.$value.'&';
+ } else {
+ my $unescapeKey = &unescape($key);
+ if (eval('$unescapeKey=~/$regexp/')) {
+ $count++;
+ if (defined($range) && $count >= $end) { last; }
+ if (defined($range) && $count < $start) { next; }
+ $result.="$key=$value&";
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ return $result;
+}
+
+sub useable_role {
+ my ($reqdmajor,$reqdminor,$major,$minor) = @_;
+ if ($reqdmajor ne '' && $reqdminor ne '') {
+ return if (($major eq '' && $minor eq '') ||
+ ($major < $reqdmajor) ||
+ (($major == $reqdmajor) && ($minor < $reqdminor)));
+ }
+ return 1;
+}
# ----------------------------------- POD (plain old documentation, CPAN style)
@@ -7878,5 +8211,7 @@ string.
=back
+=back
+
=cut