--- loncom/lonnet/perl/lonnet.pm 2008/05/29 05:44:53 1.959
+++ loncom/lonnet/perl/lonnet.pm 2008/11/29 09:57:43 1.974
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.959 2008/05/29 05:44:53 raeburn Exp $
+# $Id: lonnet.pm,v 1.974 2008/11/29 09:57:43 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -27,6 +27,47 @@
#
###
+=pod
+
+=head1 NAME
+
+Apache::lonnet.pm
+
+=head1 SYNOPSIS
+
+This file is an interface to the lonc processes of
+the LON-CAPA network as well as set of elaborated functions for handling information
+necessary for navigating through a given cluster of LON-CAPA machines within a
+domain. There are over 40 specialized functions in this module which handle the
+reading and transmission of metadata, user information (ids, names, environments, roles,
+logs), file information (storage, reading, directories, extensions, replication, embedded
+styles and descriptors), educational resources (course descriptions, section names and
+numbers), url hashing (to assign roles on a url basis), and translating abbreviated symbols to
+and from more descriptive phrases or explanations.
+
+This is part of the LearningOnline Network with CAPA project
+described at http://www.lon-capa.org.
+
+=head1 Package Variables
+
+These are largely undocumented, so if you decipher one please note it here.
+
+=over 4
+
+=item $processmarker
+
+Contains the time this process was started and this servers host id.
+
+=item $dumpcount
+
+Counts the number of times a message log flush has been attempted (regardless
+of success) by this process. Used as part of the filename when messages are
+delayed.
+
+=back
+
+=cut
+
package Apache::lonnet;
use strict;
@@ -34,7 +75,7 @@ use LWP::UserAgent();
use HTTP::Date;
# use Date::Parse;
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
- $_64bit %env);
+ $_64bit %env %protocol);
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
%userrolehash, $processmarker, $dumpcount, %coursedombuf,
@@ -61,28 +102,6 @@ require Exporter;
our @ISA = qw (Exporter);
our @EXPORT = qw(%env);
-=pod
-
-=head1 Package Variables
-
-These are largely undocumented, so if you decipher one please note it here.
-
-=over 4
-
-=item $processmarker
-
-Contains the time this process was started and this servers host id.
-
-=item $dumpcount
-
-Counts the number of times a message log flush has been attempted (regardless
-of success) by this process. Used as part of the filename when messages are
-delayed.
-
-=back
-
-=cut
-
# --------------------------------------------------------------------- Logging
{
@@ -643,7 +662,11 @@ sub spareserver {
}
if (!$want_server_name) {
- $spare_server="http://".&hostname($spare_server);
+ my $protocol = 'http';
+ if ($protocol{$spare_server} eq 'https') {
+ $protocol = $protocol{$spare_server};
+ }
+ $spare_server = $protocol.'://'.&hostname($spare_server);
}
return $spare_server;
}
@@ -958,6 +981,10 @@ sub retrieve_inst_usertypes {
if (defined(&domain($udom,'primary'))) {
my $uhome=&domain($udom,'primary');
my $rep=&reply("inst_usertypes:$udom",$uhome);
+ if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
+ &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");
+ return (\%returnhash,\@order);
+ }
my ($hashitems,$orderitems) = split(/:/,$rep);
my @pairs=split(/\&/,$hashitems);
foreach my $item (@pairs) {
@@ -1886,7 +1913,7 @@ sub process_coursefile {
print $fh $env{'form.'.$source};
close($fh);
if ($parser eq 'parse') {
- my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase);
+ my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);
unless ($parse_result eq 'ok') {
&logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
}
@@ -2094,7 +2121,7 @@ sub finishuserfileupload {
close(FH);
}
if ($parser eq 'parse') {
- my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,
+ my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles,
$codebase);
unless ($parse_result eq 'ok') {
&logthis('Failed to parse '.$filepath.$file.
@@ -2134,7 +2161,7 @@ sub finishuserfileupload {
}
sub extract_embedded_items {
- my ($filepath,$file,$allfiles,$codebase,$content) = @_;
+ my ($fullpath,$allfiles,$codebase,$content) = @_;
my @state = ();
my %javafiles = (
codebase => '',
@@ -2149,7 +2176,7 @@ sub extract_embedded_items {
if ($content) {
$p = HTML::LCParser->new($content);
} else {
- $p = HTML::LCParser->new($filepath.'/'.$file);
+ $p = HTML::LCParser->new($fullpath);
}
while (my $t=$p->get_token()) {
if ($t->[0] eq 'S') {
@@ -2592,7 +2619,7 @@ sub get_course_adv_roles {
}
} else {
my $key=&plaintext($role);
- if ($section) { $key.=' (Section '.$section.')'; }
+ if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; }
if ($returnhash{$key}) {
$returnhash{$key}.=','.$username.':'.$domain;
} else {
@@ -2762,7 +2789,7 @@ sub courseidput {
sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
- $selfenrollonly,$catfilter)=@_;
+ $selfenrollonly,$catfilter,$showhidden,$caller)=@_;
my $as_hash = 1;
my %returnhash;
if (!$domfilter) { $domfilter=''; }
@@ -2780,7 +2807,8 @@ sub courseiddump {
&escape($instcodefilter).':'.&escape($ownerfilter).
':'.&escape($coursefilter).':'.&escape($typefilter).
':'.&escape($regexp_ok).':'.$as_hash.':'.
- &escape($selfenrollonly).':'.&escape($catfilter),$tryserver);
+ &escape($selfenrollonly).':'.&escape($catfilter).':'.
+ $showhidden.':'.$caller,$tryserver);
my @pairs=split(/\&/,$rep);
foreach my $item (@pairs) {
my ($key,$value)=split(/\=/,$item,2);
@@ -3556,12 +3584,13 @@ sub privileged {
sub rolesinit {
my ($domain,$username,$authhost)=@_;
+ my %userroles;
my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
- if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
+ if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return \%userroles; }
my %allroles=();
my %allgroups=();
my $now=time;
- my %userroles = ('user.login.time' => $now);
+ %userroles = ('user.login.time' => $now);
my $group_privs;
if ($rolesdump ne '') {
@@ -4534,7 +4563,6 @@ sub allowed {
}
# Full access at system, domain or course-wide level? Exit.
-
if ($thisallowed=~/F/) {
return 'F';
}
@@ -4887,6 +4915,9 @@ sub log_query {
sub update_portfolio_table {
my ($uname,$udom,$file_name,$query,$group,$action) = @_;
+ if ($group ne '') {
+ $file_name =~s /^\Q$group\E//;
+ }
my $homeserver = &homeserver($uname,$udom);
my $queryid=
&reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
@@ -5554,7 +5585,7 @@ sub modifyuser {
my ($udom, $uname, $uid,
$umode, $upass, $first,
$middle, $last, $gene,
- $forceid, $desiredhome, $email)=@_;
+ $forceid, $desiredhome, $email, $inststatus)=@_;
$udom= &LONCAPA::clean_domain($udom);
$uname=&LONCAPA::clean_username($uname);
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
@@ -5615,7 +5646,7 @@ sub modifyuser {
# -------------------------------------------------------------- Add names, etc
my @tmp=&get('environment',
['firstname','middlename','lastname','generation','id',
- 'permanentemail'],
+ 'permanentemail','inststatus'],
$udom,$uname);
my %names;
if ($tmp[0] =~ m/^error:.*/) {
@@ -5633,19 +5664,23 @@ sub modifyuser {
if (defined($gene)) { $names{'generation'} = $gene; }
if ($email) {
$email=~s/[^\w\@\.\-\,]//gs;
- if ($email=~/\@/) { $names{'notification'} = $email;
- $names{'critnotification'} = $email;
- $names{'permanentemail'} = $email; }
+ if ($email=~/\@/) { $names{'permanentemail'} = $email; }
}
if ($uid) { $names{'id'} = $uid; }
+ if (defined($inststatus)) { $names{'inststatus'} = $inststatus; }
my $reply = &put('environment', \%names, $udom,$uname);
if ($reply ne 'ok') { return 'error: '.$reply; }
my $sqlresult = &update_allusers_table($uname,$udom,\%names);
&devalidate_cache_new('namescache',$uname.':'.$udom);
- &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
- $umode.', '.$first.', '.$middle.', '.
- $last.', '.$gene.' by '.
- $env{'user.name'}.' at '.$env{'user.domain'});
+ my $logmsg = 'Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
+ $umode.', '.$first.', '.$middle.', '.
+ $last.', '.$gene.', '.$email.', '.$inststatus;
+ if ($env{'user.name'} ne '' && $env{'user.domain'}) {
+ $logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'};
+ } else {
+ $logmsg .= ' during self creation';
+ }
+ &logthis($logmsg);
return 'ok';
}
@@ -5871,7 +5906,7 @@ sub assigncustomrole {
sub revokerole {
my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_;
my $now=time;
- return &assignrole($udom,$uname,$url,$role,$now,$deleteflag,$selfenroll,$context);
+ return &assignrole($udom,$uname,$url,$role,$now,undef,$deleteflag,$selfenroll,$context);
}
# ---------------------------------------------------------- Revoke Custom Role
@@ -6136,20 +6171,18 @@ sub modify_access_controls {
}
}
}
+ my ($group);
+ if (&is_course($domain,$user)) {
+ ($group,my $file) = split(/\//,$file_name,2);
+ }
$deloutcome = &del('file_permissions',\@deletions,$domain,$user);
$new_values{$file_name."\0".'accesscontrol'} = \%new_control;
$outcome = &put('file_permissions',\%new_values,$domain,$user);
# remove lock
my @del_lock = ($file_name."\0".'locked_access_records');
my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
- my ($file,$group);
- if (&is_course($domain,$user)) {
- ($group,$file) = split(/\//,$file_name,2);
- } else {
- $file = $file_name;
- }
my $sqlresult =
- &update_portfolio_table($user,$domain,$file,'portfolio_access',
+ &update_portfolio_table($user,$domain,$file_name,'portfolio_access',
$group);
} else {
$outcome = "error: could not obtain lockfile\n";
@@ -8510,6 +8543,12 @@ sub get_dns {
}
return $domain{$name}{$what};
}
+
+ sub domain_info {
+ &load_domain_tab() if (!$loaded);
+ return %domain;
+ }
+
}
@@ -8527,13 +8566,22 @@ sub get_dns {
next if ($configline =~ /^(\#|\s*$ )/x);
next if ($configline =~ /^\^/);
chomp($configline);
- my ($id,$domain,$role,$name)=split(/:/,$configline);
+ my ($id,$domain,$role,$name,$protocol)=split(/:/,$configline);
$name=~s/\s//g;
if ($id && $domain && $role && $name) {
$hostname{$id}=$name;
push(@{$name_to_host{$name}}, $id);
$hostdom{$id}=$domain;
if ($role eq 'library') { $libserv{$id}=$name; }
+ if (defined($protocol)) {
+ if ($protocol eq 'https') {
+ $protocol{$id} = $protocol;
+ } else {
+ $protocol{$id} = 'http';
+ }
+ } else {
+ $protocol{$id} = 'http';
+ }
}
}
}
@@ -8578,6 +8626,11 @@ sub get_dns {
return %name_to_host;
}
+ sub all_host_domain {
+ &load_hosts_tab() if (!$loaded);
+ return %hostdom;
+ }
+
sub is_library {
&load_hosts_tab() if (!$loaded);
@@ -8976,7 +9029,7 @@ when the connection is brought back up
=item * B<con_failed>: unable to contact remote host and unable to save message
for later delivery
-=item * B<error:>: an error a occured, a description of the error follows the :
+=item * B<error:>: an error a occurred, a description of the error follows the :
=item * B<no_such_host>: unable to fund a host associated with the user/domain
that was requested
@@ -9143,7 +9196,8 @@ modifyuserauth($udom,$uname,$umode,$upas
=item *
-modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) :
+modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,
+ $forceid,$desiredhome,$email,$inststatus) :
modify user
=item *
@@ -9166,7 +9220,7 @@ Inputs:
=item B<$uname> Student's loncapa login name
-=item B<$uid> Student's id/student number
+=item B<$uid> Student/Employee ID
=item B<$umode> Student's authentication mode
@@ -9194,13 +9248,15 @@ Inputs:
=item B<$type> Type of enrollment (auto or manual)
-=item B<$locktype>
+=item B<$locktype> boolean - enrollment type locked to prevent Autoenroll.pl changing manual to auto
+
+=item B<$cid> courseID - needed if a course role is assigned by a user whose current role is DC
-=item B<$cid>
+=item B<$selfenroll> boolean - 1 if user role change occurred via self-enrollment
-=item B<$selfenroll>
+=item B<$context> role change context (shown in User Management Logs display in a course)
-=item B<$context>
+=item B<$inststatus> institutional status of user - : separated string of escaped status types
=back
@@ -9553,7 +9609,7 @@ Returns:
'key_exists: <key>' -> failed to anything out of $storehash, as at
least <key> already existed in the db (other
requested keys may also already exist)
- 'error: <msg>' -> unable to tie the DB or other erorr occured
+ 'error: <msg>' -> unable to tie the DB or other error occurred
'con_lost' -> unable to contact request server
'refused' -> action was not allowed by remote machine