--- loncom/lonnet/perl/lonnet.pm 2008/04/30 22:42:59 1.957
+++ loncom/lonnet/perl/lonnet.pm 2008/11/12 20:01:15 1.971
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.957 2008/04/30 22:42:59 raeburn Exp $
+# $Id: lonnet.pm,v 1.971 2008/11/12 20:01:15 jms Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -27,6 +27,28 @@
#
###
+=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
+
package Apache::lonnet;
use strict;
@@ -34,12 +56,12 @@ 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,
%coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,
- %courseownerbuf, %coursetypebuf);
+ %courseownerbuf, %coursetypebuf,$locknum);
use IO::Socket;
use GDBM_File;
@@ -61,28 +83,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
{
@@ -526,6 +526,51 @@ sub get_env_multiple {
return(@values);
}
+# ------------------------------------------------------------------- Locking
+
+sub set_lock {
+ my ($text)=@_;
+ $locknum++;
+ my $id=$$.'-'.$locknum;
+ &appenv({'session.locks' => $env{'session.locks'}.','.$id,
+ 'session.lock.'.$id => $text});
+ return $id;
+}
+
+sub get_locks {
+ my $num=0;
+ my %texts=();
+ foreach my $lock (split(/\,/,$env{'session.locks'})) {
+ if ($lock=~/\w/) {
+ $num++;
+ $texts{$lock}=$env{'session.lock.'.$lock};
+ }
+ }
+ return ($num,%texts);
+}
+
+sub remove_lock {
+ my ($id)=@_;
+ my $newlocks='';
+ foreach my $lock (split(/\,/,$env{'session.locks'})) {
+ if (($lock=~/\w/) && ($lock ne $id)) {
+ $newlocks.=','.$lock;
+ }
+ }
+ &appenv({'session.locks' => $newlocks});
+ &delenv('session.lock.'.$id);
+}
+
+sub remove_all_locks {
+ my $activelocks=$env{'session.locks'};
+ foreach my $lock (split(/\,/,$env{'session.locks'})) {
+ if ($lock=~/\w/) {
+ &remove_lock($lock);
+ }
+ }
+}
+
+
# ------------------------------------------ Find out current server userload
sub userload {
my $numusers=0;
@@ -598,7 +643,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;
}
@@ -913,6 +962,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) {
@@ -1841,7 +1894,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);
}
@@ -2049,7 +2102,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.
@@ -2089,7 +2142,7 @@ sub finishuserfileupload {
}
sub extract_embedded_items {
- my ($filepath,$file,$allfiles,$codebase,$content) = @_;
+ my ($fullpath,$allfiles,$codebase,$content) = @_;
my @state = ();
my %javafiles = (
codebase => '',
@@ -2104,7 +2157,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') {
@@ -2717,7 +2770,7 @@ sub courseidput {
sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
- $selfenrollonly)=@_;
+ $selfenrollonly,$catfilter,$showhidden,$caller)=@_;
my $as_hash = 1;
my %returnhash;
if (!$domfilter) { $domfilter=''; }
@@ -2735,7 +2788,8 @@ sub courseiddump {
&escape($instcodefilter).':'.&escape($ownerfilter).
':'.&escape($coursefilter).':'.&escape($typefilter).
':'.&escape($regexp_ok).':'.$as_hash.':'.
- &escape($selfenrollonly),$tryserver);
+ &escape($selfenrollonly).':'.&escape($catfilter).':'.
+ $showhidden.':'.$caller,$tryserver);
my @pairs=split(/\&/,$rep);
foreach my $item (@pairs) {
my ($key,$value)=split(/\=/,$item,2);
@@ -3511,12 +3565,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 '') {
@@ -4489,7 +4544,6 @@ sub allowed {
}
# Full access at system, domain or course-wide level? Exit.
-
if ($thisallowed=~/F/) {
return 'F';
}
@@ -4842,6 +4896,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).
@@ -5509,7 +5566,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.', '.
@@ -5570,7 +5627,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:.*/) {
@@ -5588,19 +5645,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';
}
@@ -5826,7 +5887,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
@@ -6091,20 +6152,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";
@@ -8482,13 +8541,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';
+ }
}
}
}
@@ -8763,6 +8831,7 @@ $memcache=new Cache::Memcached({'servers
$processmarker='_'.time.'_'.$perlvar{'lonHostID'};
$dumpcount=0;
+$locknum=0;
&logtouch();
&logthis('INFO: Read configuration');
@@ -8930,7 +8999,7 @@ when the connection is brought back up
=item * B: unable to contact remote host and unable to save message
for later delivery
-=item * B: an error a occured, a description of the error follows the :
+=item * B: an error a occurred, a description of the error follows the :
=item * B: unable to fund a host associated with the user/domain
that was requested
@@ -9097,7 +9166,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 *
@@ -9120,7 +9190,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
@@ -9148,13 +9218,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
@@ -9507,7 +9579,7 @@ Returns:
'key_exists: ' -> failed to anything out of $storehash, as at
least already existed in the db (other
requested keys may also already exist)
- 'error: ' -> unable to tie the DB or other erorr occured
+ 'error: ' -> unable to tie the DB or other error occurred
'con_lost' -> unable to contact request server
'refused' -> action was not allowed by remote machine