|
version 1.958, 2008/05/12 20:59:15
|
version 1.971, 2008/11/12 20:01:15
|
|
Line 27
|
Line 27
|
| # |
# |
| ### |
### |
| |
|
| |
=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; |
package Apache::lonnet; |
| |
|
| use strict; |
use strict; |
|
Line 34 use LWP::UserAgent();
|
Line 56 use LWP::UserAgent();
|
| use HTTP::Date; |
use HTTP::Date; |
| # use Date::Parse; |
# use Date::Parse; |
| use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir |
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir |
| $_64bit %env); |
$_64bit %env %protocol); |
| |
|
| my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, |
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, |
| %userrolehash, $processmarker, $dumpcount, %coursedombuf, |
%userrolehash, $processmarker, $dumpcount, %coursedombuf, |
|
Line 61 require Exporter;
|
Line 83 require Exporter;
|
| our @ISA = qw (Exporter); |
our @ISA = qw (Exporter); |
| our @EXPORT = qw(%env); |
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 |
# --------------------------------------------------------------------- Logging |
| { |
{ |
|
Line 643 sub spareserver {
|
Line 643 sub spareserver {
|
| } |
} |
| |
|
| if (!$want_server_name) { |
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; |
return $spare_server; |
| } |
} |
|
Line 958 sub retrieve_inst_usertypes {
|
Line 962 sub retrieve_inst_usertypes {
|
| if (defined(&domain($udom,'primary'))) { |
if (defined(&domain($udom,'primary'))) { |
| my $uhome=&domain($udom,'primary'); |
my $uhome=&domain($udom,'primary'); |
| my $rep=&reply("inst_usertypes:$udom",$uhome); |
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 ($hashitems,$orderitems) = split(/:/,$rep); |
| my @pairs=split(/\&/,$hashitems); |
my @pairs=split(/\&/,$hashitems); |
| foreach my $item (@pairs) { |
foreach my $item (@pairs) { |
|
Line 1886 sub process_coursefile {
|
Line 1894 sub process_coursefile {
|
| print $fh $env{'form.'.$source}; |
print $fh $env{'form.'.$source}; |
| close($fh); |
close($fh); |
| if ($parser eq 'parse') { |
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') { |
unless ($parse_result eq 'ok') { |
| &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result); |
&logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result); |
| } |
} |
|
Line 2094 sub finishuserfileupload {
|
Line 2102 sub finishuserfileupload {
|
| close(FH); |
close(FH); |
| } |
} |
| if ($parser eq 'parse') { |
if ($parser eq 'parse') { |
| my $parse_result = &extract_embedded_items($filepath,$file,$allfiles, |
my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles, |
| $codebase); |
$codebase); |
| unless ($parse_result eq 'ok') { |
unless ($parse_result eq 'ok') { |
| &logthis('Failed to parse '.$filepath.$file. |
&logthis('Failed to parse '.$filepath.$file. |
|
Line 2134 sub finishuserfileupload {
|
Line 2142 sub finishuserfileupload {
|
| } |
} |
| |
|
| sub extract_embedded_items { |
sub extract_embedded_items { |
| my ($filepath,$file,$allfiles,$codebase,$content) = @_; |
my ($fullpath,$allfiles,$codebase,$content) = @_; |
| my @state = (); |
my @state = (); |
| my %javafiles = ( |
my %javafiles = ( |
| codebase => '', |
codebase => '', |
|
Line 2149 sub extract_embedded_items {
|
Line 2157 sub extract_embedded_items {
|
| if ($content) { |
if ($content) { |
| $p = HTML::LCParser->new($content); |
$p = HTML::LCParser->new($content); |
| } else { |
} else { |
| $p = HTML::LCParser->new($filepath.'/'.$file); |
$p = HTML::LCParser->new($fullpath); |
| } |
} |
| while (my $t=$p->get_token()) { |
while (my $t=$p->get_token()) { |
| if ($t->[0] eq 'S') { |
if ($t->[0] eq 'S') { |
|
Line 2762 sub courseidput {
|
Line 2770 sub courseidput {
|
| sub courseiddump { |
sub courseiddump { |
| my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, |
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, |
| $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, |
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, |
| $selfenrollonly)=@_; |
$selfenrollonly,$catfilter,$showhidden,$caller)=@_; |
| my $as_hash = 1; |
my $as_hash = 1; |
| my %returnhash; |
my %returnhash; |
| if (!$domfilter) { $domfilter=''; } |
if (!$domfilter) { $domfilter=''; } |
|
Line 2780 sub courseiddump {
|
Line 2788 sub courseiddump {
|
| &escape($instcodefilter).':'.&escape($ownerfilter). |
&escape($instcodefilter).':'.&escape($ownerfilter). |
| ':'.&escape($coursefilter).':'.&escape($typefilter). |
':'.&escape($coursefilter).':'.&escape($typefilter). |
| ':'.&escape($regexp_ok).':'.$as_hash.':'. |
':'.&escape($regexp_ok).':'.$as_hash.':'. |
| &escape($selfenrollonly),$tryserver); |
&escape($selfenrollonly).':'.&escape($catfilter).':'. |
| |
$showhidden.':'.$caller,$tryserver); |
| my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
| foreach my $item (@pairs) { |
foreach my $item (@pairs) { |
| my ($key,$value)=split(/\=/,$item,2); |
my ($key,$value)=split(/\=/,$item,2); |
|
Line 3556 sub privileged {
|
Line 3565 sub privileged {
|
| |
|
| sub rolesinit { |
sub rolesinit { |
| my ($domain,$username,$authhost)=@_; |
my ($domain,$username,$authhost)=@_; |
| |
my %userroles; |
| my $rolesdump=reply("dump:$domain:$username:roles",$authhost); |
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 %allroles=(); |
| my %allgroups=(); |
my %allgroups=(); |
| my $now=time; |
my $now=time; |
| my %userroles = ('user.login.time' => $now); |
%userroles = ('user.login.time' => $now); |
| my $group_privs; |
my $group_privs; |
| |
|
| if ($rolesdump ne '') { |
if ($rolesdump ne '') { |
|
Line 4534 sub allowed {
|
Line 4544 sub allowed {
|
| } |
} |
| |
|
| # Full access at system, domain or course-wide level? Exit. |
# Full access at system, domain or course-wide level? Exit. |
| |
|
| if ($thisallowed=~/F/) { |
if ($thisallowed=~/F/) { |
| return 'F'; |
return 'F'; |
| } |
} |
|
Line 4887 sub log_query {
|
Line 4896 sub log_query {
|
| |
|
| sub update_portfolio_table { |
sub update_portfolio_table { |
| my ($uname,$udom,$file_name,$query,$group,$action) = @_; |
my ($uname,$udom,$file_name,$query,$group,$action) = @_; |
| |
if ($group ne '') { |
| |
$file_name =~s /^\Q$group\E//; |
| |
} |
| my $homeserver = &homeserver($uname,$udom); |
my $homeserver = &homeserver($uname,$udom); |
| my $queryid= |
my $queryid= |
| &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group). |
&reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group). |
|
Line 5554 sub modifyuser {
|
Line 5566 sub modifyuser {
|
| my ($udom, $uname, $uid, |
my ($udom, $uname, $uid, |
| $umode, $upass, $first, |
$umode, $upass, $first, |
| $middle, $last, $gene, |
$middle, $last, $gene, |
| $forceid, $desiredhome, $email)=@_; |
$forceid, $desiredhome, $email, $inststatus)=@_; |
| $udom= &LONCAPA::clean_domain($udom); |
$udom= &LONCAPA::clean_domain($udom); |
| $uname=&LONCAPA::clean_username($uname); |
$uname=&LONCAPA::clean_username($uname); |
| &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
|
Line 5615 sub modifyuser {
|
Line 5627 sub modifyuser {
|
| # -------------------------------------------------------------- Add names, etc |
# -------------------------------------------------------------- Add names, etc |
| my @tmp=&get('environment', |
my @tmp=&get('environment', |
| ['firstname','middlename','lastname','generation','id', |
['firstname','middlename','lastname','generation','id', |
| 'permanentemail'], |
'permanentemail','inststatus'], |
| $udom,$uname); |
$udom,$uname); |
| my %names; |
my %names; |
| if ($tmp[0] =~ m/^error:.*/) { |
if ($tmp[0] =~ m/^error:.*/) { |
|
Line 5633 sub modifyuser {
|
Line 5645 sub modifyuser {
|
| if (defined($gene)) { $names{'generation'} = $gene; } |
if (defined($gene)) { $names{'generation'} = $gene; } |
| if ($email) { |
if ($email) { |
| $email=~s/[^\w\@\.\-\,]//gs; |
$email=~s/[^\w\@\.\-\,]//gs; |
| if ($email=~/\@/) { $names{'notification'} = $email; |
if ($email=~/\@/) { $names{'permanentemail'} = $email; } |
| $names{'critnotification'} = $email; |
|
| $names{'permanentemail'} = $email; } |
|
| } |
} |
| if ($uid) { $names{'id'} = $uid; } |
if ($uid) { $names{'id'} = $uid; } |
| |
if (defined($inststatus)) { $names{'inststatus'} = $inststatus; } |
| my $reply = &put('environment', \%names, $udom,$uname); |
my $reply = &put('environment', \%names, $udom,$uname); |
| if ($reply ne 'ok') { return 'error: '.$reply; } |
if ($reply ne 'ok') { return 'error: '.$reply; } |
| my $sqlresult = &update_allusers_table($uname,$udom,\%names); |
my $sqlresult = &update_allusers_table($uname,$udom,\%names); |
| &devalidate_cache_new('namescache',$uname.':'.$udom); |
&devalidate_cache_new('namescache',$uname.':'.$udom); |
| &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. |
my $logmsg = 'Success modifying user '.$udom.', '.$uname.', '.$uid.', '. |
| $umode.', '.$first.', '.$middle.', '. |
$umode.', '.$first.', '.$middle.', '. |
| $last.', '.$gene.' by '. |
$last.', '.$gene.', '.$email.', '.$inststatus; |
| $env{'user.name'}.' at '.$env{'user.domain'}); |
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'; |
return 'ok'; |
| } |
} |
| |
|
|
Line 5871 sub assigncustomrole {
|
Line 5887 sub assigncustomrole {
|
| sub revokerole { |
sub revokerole { |
| my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_; |
my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_; |
| my $now=time; |
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 |
# ---------------------------------------------------------- Revoke Custom Role |
|
Line 6136 sub modify_access_controls {
|
Line 6152 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); |
$deloutcome = &del('file_permissions',\@deletions,$domain,$user); |
| $new_values{$file_name."\0".'accesscontrol'} = \%new_control; |
$new_values{$file_name."\0".'accesscontrol'} = \%new_control; |
| $outcome = &put('file_permissions',\%new_values,$domain,$user); |
$outcome = &put('file_permissions',\%new_values,$domain,$user); |
| # remove lock |
# remove lock |
| my @del_lock = ($file_name."\0".'locked_access_records'); |
my @del_lock = ($file_name."\0".'locked_access_records'); |
| my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user); |
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 = |
my $sqlresult = |
| &update_portfolio_table($user,$domain,$file,'portfolio_access', |
&update_portfolio_table($user,$domain,$file_name,'portfolio_access', |
| $group); |
$group); |
| } else { |
} else { |
| $outcome = "error: could not obtain lockfile\n"; |
$outcome = "error: could not obtain lockfile\n"; |
|
Line 8527 sub get_dns {
|
Line 8541 sub get_dns {
|
| next if ($configline =~ /^(\#|\s*$ )/x); |
next if ($configline =~ /^(\#|\s*$ )/x); |
| next if ($configline =~ /^\^/); |
next if ($configline =~ /^\^/); |
| chomp($configline); |
chomp($configline); |
| my ($id,$domain,$role,$name)=split(/:/,$configline); |
my ($id,$domain,$role,$name,$protocol)=split(/:/,$configline); |
| $name=~s/\s//g; |
$name=~s/\s//g; |
| if ($id && $domain && $role && $name) { |
if ($id && $domain && $role && $name) { |
| $hostname{$id}=$name; |
$hostname{$id}=$name; |
| push(@{$name_to_host{$name}}, $id); |
push(@{$name_to_host{$name}}, $id); |
| $hostdom{$id}=$domain; |
$hostdom{$id}=$domain; |
| if ($role eq 'library') { $libserv{$id}=$name; } |
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'; |
| |
} |
| } |
} |
| } |
} |
| } |
} |
|
Line 8976 when the connection is brought back up
|
Line 8999 when the connection is brought back up
|
| =item * B<con_failed>: unable to contact remote host and unable to save message |
=item * B<con_failed>: unable to contact remote host and unable to save message |
| for later delivery |
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 |
=item * B<no_such_host>: unable to fund a host associated with the user/domain |
| that was requested |
that was requested |
|
Line 9143 modifyuserauth($udom,$uname,$umode,$upas
|
Line 9166 modifyuserauth($udom,$uname,$umode,$upas
|
| |
|
| =item * |
=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 |
modify user |
| |
|
| =item * |
=item * |
|
Line 9166 Inputs:
|
Line 9190 Inputs:
|
| |
|
| =item B<$uname> Student's loncapa login name |
=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 |
=item B<$umode> Student's authentication mode |
| |
|
|
Line 9194 Inputs:
|
Line 9218 Inputs:
|
| |
|
| =item B<$type> Type of enrollment (auto or manual) |
=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 |
=back |
| |
|
|
Line 9553 Returns:
|
Line 9579 Returns:
|
| 'key_exists: <key>' -> failed to anything out of $storehash, as at |
'key_exists: <key>' -> failed to anything out of $storehash, as at |
| least <key> already existed in the db (other |
least <key> already existed in the db (other |
| requested keys may also already exist) |
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 |
'con_lost' -> unable to contact request server |
| 'refused' -> action was not allowed by remote machine |
'refused' -> action was not allowed by remote machine |
| |
|
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl