--- loncom/lonnet/perl/lonnet.pm 2014/07/29 05:55:24 1.1172.2.54
+++ loncom/lonnet/perl/lonnet.pm 2014/04/23 10:11:34 1.1256
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1172.2.54 2014/07/29 05:55:24 raeburn Exp $
+# $Id: lonnet.pm,v 1.1256 2014/04/23 10:11:34 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -75,6 +75,9 @@ use LWP::UserAgent();
use HTTP::Date;
use Image::Magick;
+
+use Encode;
+
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
%managerstab);
@@ -109,6 +112,7 @@ require Exporter;
our @ISA = qw (Exporter);
our @EXPORT = qw(%env);
+
# ------------------------------------ Logging (parameters, docs, slots, roles)
{
my $logid;
@@ -123,19 +127,19 @@ our @EXPORT = qw(%env);
$logid ++;
my $now = time();
my $id=$now.'00000'.$$.'00000'.$logid;
- my $logentry = {
- $id => {
- 'exe_uname' => $env{'user.name'},
- 'exe_udom' => $env{'user.domain'},
- 'exe_time' => $now,
- 'exe_ip' => $ENV{'REMOTE_ADDR'},
- 'delflag' => $delflag,
- 'logentry' => $storehash,
- 'uname' => $uname,
- 'udom' => $udom,
- }
+ my $logentry = {
+ $id => {
+ 'exe_uname' => $env{'user.name'},
+ 'exe_udom' => $env{'user.domain'},
+ 'exe_time' => $now,
+ 'exe_ip' => $ENV{'REMOTE_ADDR'},
+ 'delflag' => $delflag,
+ 'logentry' => $storehash,
+ 'uname' => $uname,
+ 'udom' => $udom,
+ }
};
- return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);
+ return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);
}
}
@@ -356,7 +360,8 @@ sub remote_devalidate_cache {
my $items;
return unless (ref($cachekeys) eq 'ARRAY');
my $cachestr = join('&',@{$cachekeys});
- return &reply('devalidatecache:'.&escape($cachestr),$lonhost);
+ my $response = &reply('devalidatecache:'.&escape($cachestr),$lonhost);
+ return $response;
}
# -------------------------------------------------- Non-critical communication
@@ -956,30 +961,13 @@ sub has_user_session {
# --------- determine least loaded server in a user's domain which allows login
sub choose_server {
- my ($udom,$checkloginvia,$required,$skiploadbal) = @_;
+ my ($udom,$checkloginvia,$required) = @_;
my %domconfhash = &Apache::loncommon::get_domainconf($udom);
my %servers = &get_servers($udom);
my $lowest_load = 30000;
- my ($login_host,$hostname,$portal_path,$isredirect,$balancers);
- if ($skiploadbal) {
- ($balancers,my $cached)=&is_cached_new('loadbalancing',$udom);
- unless (defined($cached)) {
- my $cachetime = 60*60*24;
- my %domconfig =
- &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);
- if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
- $balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'},
- $cachetime);
- }
- }
- }
+ my ($login_host,$hostname,$portal_path,$isredirect);
foreach my $lonhost (keys(%servers)) {
my $loginvia;
- if ($skiploadbal) {
- if (ref($balancers) eq 'HASH') {
- next if (exists($balancers->{$lonhost}));
- }
- }
if ($checkloginvia) {
$loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
if ($loginvia) {
@@ -1297,7 +1285,7 @@ sub check_loadbalancing {
}
}
if (ref($result) eq 'HASH') {
- ($is_balancer,$currtargets,$currrules) =
+ ($is_balancer,$currtargets,$currrules) =
&check_balancer_result($result,@hosts);
if ($is_balancer) {
if (ref($currrules) eq 'HASH') {
@@ -1356,7 +1344,7 @@ sub check_loadbalancing {
}
}
if (ref($result) eq 'HASH') {
- ($is_balancer,$currtargets,$currrules) =
+ ($is_balancer,$currtargets,$currrules) =
&check_balancer_result($result,@hosts);
if ($is_balancer) {
if (ref($currrules) eq 'HASH') {
@@ -1412,8 +1400,8 @@ sub check_loadbalancing {
$is_balancer = 0;
if ($uname ne '' && $udom ne '') {
if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
-
- &appenv({'user.loadbalexempt' => $lonhost,
+
+ &appenv({'user.loadbalexempt' => $lonhost,
'user.loadbalcheck.time' => time});
}
}
@@ -1602,7 +1590,7 @@ sub idput {
}
}
-# ---------------------------------------- Delete unwanted IDs from ids.db file
+# ---------------------------------------- Delete unwanted IDs from ids.db file
sub iddel {
my ($udom,$idshashref,$uhome)=@_;
@@ -2023,8 +2011,7 @@ sub get_domain_defaults {
&Apache::lonnet::get_dom('configuration',['defaults','quotas',
'requestcourses','inststatus',
'coursedefaults','usersessions',
- 'requestauthor','selfenrollment',
- 'coursecategories'],$domain);
+ 'requestauthor','selfenrollment'],$domain);
my @coursetypes = ('official','unofficial','community','textbook');
if (ref($domconfig{'defaults'}) eq 'HASH') {
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
@@ -2068,6 +2055,7 @@ sub get_domain_defaults {
}
}
if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
+ $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};
foreach my $type (@coursetypes) {
if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
unless ($type eq 'community') {
@@ -2115,16 +2103,6 @@ sub get_domain_defaults {
}
}
}
- if (ref($domconfig{'coursecategories'}) eq 'HASH') {
- $domdefaults{'catauth'} = 'std';
- $domdefaults{'catunauth'} = 'std';
- if ($domconfig{'coursecategories'}{'auth'}) {
- $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'};
- }
- if ($domconfig{'coursecategories'}{'unauth'}) {
- $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};
- }
- }
&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
return %domdefaults;
}
@@ -2722,10 +2700,13 @@ sub ssi {
$request->header(Cookie => $ENV{'HTTP_COOKIE'});
my $response= $ua->request($request);
+ my $content = $response->content;
+
+
if (wantarray) {
- return ($response->content, $response);
+ return ($content, $response);
} else {
- return $response->content;
+ return $content;
}
}
@@ -2757,7 +2738,7 @@ sub allowuploaded {
#
# Determine if the current user should be able to edit a particular resource,
# when viewing in course context.
-# (a) When viewing resource used to determine if "Edit" item is included in
+# (a) When viewing resource used to determine if "Edit" item is included in
# Functions.
# (b) When displaying folder contents in course editor, used to determine if
# "Edit" link will be displayed alongside resource.
@@ -2765,12 +2746,12 @@ sub allowuploaded {
# input: six args -- filename (decluttered), course number, course domain,
# url, symb (if registered) and group (if this is a group
# item -- e.g., bulletin board, group page etc.).
-# output: array of five scalars --
+# output: array of five scalars --
# $cfile -- url for file editing if editable on current server
# $home -- homeserver of resource (i.e., for author if published,
# or course if uploaded.).
# $switchserver -- 1 if server switch will be needed.
-# $forceedit -- 1 if icon/link should be to go to edit mode
+# $forceedit -- 1 if icon/link should be to go to edit mode
# $forceview -- 1 if icon/link should be to go to view mode
#
@@ -2859,7 +2840,7 @@ sub can_edit_resource {
$forceedit = 1;
}
$cfile = $resurl;
- } elsif (($resurl ne '') && (&is_on_map($resurl))) {
+ } elsif (($resurl ne '') && (&is_on_map($resurl))) {
if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) {
$incourse = 1;
if ($env{'form.forceedit'}) {
@@ -2890,7 +2871,7 @@ sub can_edit_resource {
}
} elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') {
my $template = '/res/lib/templates/simpleproblem.problem';
- if (&is_on_map($template)) {
+ if (&is_on_map($template)) {
$incourse = 1;
$forceview = 1;
$cfile = $template;
@@ -2937,7 +2918,7 @@ sub can_edit_resource {
$cfile=$file;
}
}
- if (($cfile ne '') && (!$incourse || $uploaded) &&
+ if (($cfile ne '') && (!$incourse || $uploaded) &&
(($home ne '') && ($home ne 'no_host'))) {
my @ids=¤t_machine_ids();
unless (grep(/^\Q$home\E$/,@ids)) {
@@ -2964,9 +2945,9 @@ sub in_course {
if ($hideprivileged) {
my $skipuser;
my %coursehash = &coursedescription($cdom.'_'.$cnum);
- my @possdoms = ($cdom);
- if ($coursehash{'checkforpriv'}) {
- push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));
+ my @possdoms = ($cdom);
+ if ($coursehash{'checkforpriv'}) {
+ push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));
}
if (&privileged($uname,$udom,\@possdoms)) {
$skipuser = 1;
@@ -3470,7 +3451,7 @@ sub extract_embedded_items {
}
if (lc($tagname) eq 'a') {
unless (($attr->{'href'} =~ /^#/) || ($attr->{'href'} eq '')) {
- &add_filetype($allfiles,$attr->{'href'},'href');
+ &add_filetype($allfiles,$attr->{'href'},'href');
}
}
if (lc($tagname) eq 'script') {
@@ -4141,7 +4122,7 @@ sub get_my_roles {
} else {
my $possdoms = [$domain];
if (ref($roledoms) eq 'ARRAY') {
- push(@{$possdoms},@{$roledoms});
+ push(@{$possdoms},@{$roledoms});
}
if (&privileged($username,$domain,$possdoms,\@privroles)) {
if (!$nothide{$username.':'.$domain}) {
@@ -4249,16 +4230,16 @@ sub courseiddump {
if (($domfilter eq '') ||
(&host_domain($tryserver) eq $domfilter)) {
my $rep;
- if (grep { $_ eq $tryserver } ¤t_machine_ids()) {
- $rep = &LONCAPA::Lond::dump_course_id_handler(
- join(":", (&host_domain($tryserver), $sincefilter,
- &escape($descfilter), &escape($instcodefilter),
+ if (grep { $_ eq $tryserver } current_machine_ids()) {
+ $rep = LONCAPA::Lond::dump_course_id_handler(
+ join(":", (&host_domain($tryserver), $sincefilter,
+ &escape($descfilter), &escape($instcodefilter),
&escape($ownerfilter), &escape($coursefilter),
- &escape($typefilter), &escape($regexp_ok),
- $as_hash, &escape($selfenrollonly),
- &escape($catfilter), $showhidden, $caller,
- &escape($cloner), &escape($cc_clone), $cloneonly,
- &escape($createdbefore), &escape($createdafter),
+ &escape($typefilter), &escape($regexp_ok),
+ $as_hash, &escape($selfenrollonly),
+ &escape($catfilter), $showhidden, $caller,
+ &escape($cloner), &escape($cc_clone), $cloneonly,
+ &escape($createdbefore), &escape($createdafter),
&escape($creationcontext), $domcloner, $hasuniquecode)));
} else {
$rep = &reply('courseiddump:'.&host_domain($tryserver).':'.
@@ -4273,7 +4254,7 @@ sub courseiddump {
&escape($creationcontext).':'.$domcloner.':'.$hasuniquecode,
$tryserver);
}
-
+
my @pairs=split(/\&/,$rep);
foreach my $item (@pairs) {
my ($key,$value)=split(/\=/,$item,2);
@@ -4472,92 +4453,6 @@ sub set_first_access {
return 'already_set';
}
}
-
-sub checkout {
- my ($symb,$tuname,$tudom,$tcrsid)=@_;
- my $now=time;
- my $lonhost=$perlvar{'lonHostID'};
- my $infostr=&escape(
- 'CHECKOUTTOKEN&'.
- $tuname.'&'.
- $tudom.'&'.
- $tcrsid.'&'.
- $symb.'&'.
- $now.'&'.$ENV{'REMOTE_ADDR'});
- my $token=&reply('tmpput:'.$infostr,$lonhost);
- if ($token=~/^error\:/) {
- &logthis("WARNING: ".
- "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
- "");
- return '';
- }
-
- $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
- $token=~tr/a-z/A-Z/;
-
- my %infohash=('resource.0.outtoken' => $token,
- 'resource.0.checkouttime' => $now,
- 'resource.0.outremote' => $ENV{'REMOTE_ADDR'});
-
- unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
- return '';
- } else {
- &logthis("WARNING: ".
- "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
- "");
- }
-
- if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
- &escape('Checkout '.$infostr.' - '.
- $token)) ne 'ok') {
- return '';
- } else {
- &logthis("WARNING: ".
- "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
- "");
- }
- return $token;
-}
-
-# ------------------------------------------------------------ Check in an item
-
-sub checkin {
- my $token=shift;
- my $now=time;
- my ($ta,$tb,$lonhost)=split(/\*/,$token);
- $lonhost=~tr/A-Z/a-z/;
- my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
- $dtoken=~s/\W/\_/g;
- my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
- split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
-
- unless (($tuname) && ($tudom)) {
- &logthis('Check in '.$token.' ('.$dtoken.') failed');
- return '';
- }
-
- unless (&allowed('mgr',$tcrsid)) {
- &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
- $env{'user.name'}.' - '.$env{'user.domain'});
- return '';
- }
-
- my %infohash=('resource.0.intoken' => $token,
- 'resource.0.checkintime' => $now,
- 'resource.0.inremote' => $ENV{'REMOTE_ADDR'});
-
- unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
- return '';
- }
-
- if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
- &escape('Checkin - '.$token)) ne 'ok') {
- return '';
- }
-
- return ($symb,$tuname,$tudom,$tcrsid);
-}
-
# --------------------------------------------- Set Expire Date for Spreadsheet
sub expirespread {
@@ -5151,7 +5046,7 @@ sub privileged {
my $now = time;
my $roles;
if (ref($possroles) eq 'ARRAY') {
- $roles = $possroles;
+ $roles = $possroles;
} else {
$roles = ['dc','su'];
}
@@ -5178,7 +5073,7 @@ sub privileged {
for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {
my ($trole, $tend, $tstart) = split(/_/, $role);
if (grep(/^\Q$trole\E$/,@{$roles})) {
- return 1 unless ($tend && $tend < $now)
+ return 1 unless ($tend && $tend < $now)
or ($tstart && $tstart > $now);
}
}
@@ -5216,7 +5111,7 @@ sub privileged_by_domain {
my ($trole,$uname,$udom,$rest) = split(/:/,$item,4);
my ($end,$start) = split(/:/,$dompersonnel{$server}{$item});
next if ($end && $end < $now);
- $privileged{$dom}{$trole}{$uname.':'.$udom} =
+ $privileged{$dom}{$trole}{$uname.':'.$udom} =
$dompersonnel{$server}{$item};
}
}
@@ -5687,14 +5582,15 @@ sub unserialize {
return {} if $rep =~ /^error/;
my %returnhash=();
- foreach my $item (split(/\&/,$rep)) {
- my ($key, $value) = split(/=/, $item, 2);
- $key = unescape($key) unless $escapedkeys;
- next if $key =~ /^error: 2 /;
- $returnhash{$key} = &thaw_unescape($value);
- }
+ foreach my $item (split(/\&/,$rep)) {
+ my ($key, $value) = split(/=/, $item, 2);
+ $key = unescape($key) unless $escapedkeys;
+ next if $key =~ /^error: 2 /;
+ $returnhash{$key} = &thaw_unescape($value);
+ }
+ #return %returnhash;
return \%returnhash;
-}
+}
# see Lond::dump_with_regexp
# if $escapedkeys hash keys won't get unescaped.
@@ -5705,11 +5601,11 @@ sub dump {
my $uhome=&homeserver($uname,$udomain);
my $reply;
- if (grep { $_ eq $uhome } ¤t_machine_ids()) {
+ if (grep { $_ eq $uhome } current_machine_ids()) {
# user is hosted on this machine
- $reply = LONCAPA::Lond::dump_with_regexp(join(':', ($udomain,
+ $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain,
$uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
- return %{&unserialize($reply, $escapedkeys)};
+ return %{unserialize($reply, $escapedkeys)};
}
if ($regexp) {
$regexp=&escape($regexp);
@@ -5722,7 +5618,8 @@ sub dump {
if (!($rep =~ /^error/ )) {
foreach my $item (@pairs) {
my ($key,$value)=split(/=/,$item,2);
- $key = &unescape($key) unless ($escapedkeys);
+ $key = unescape($key) unless $escapedkeys;
+ #$key = &unescape($key);
next if ($key =~ /^error: 2 /);
$returnhash{$key}=&thaw_unescape($value);
}
@@ -5766,7 +5663,7 @@ sub currentdump {
my $rep;
if (grep { $_ eq $uhome } current_machine_ids()) {
- $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname,
+ $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname,
$courseid)));
} else {
$rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
@@ -6014,13 +5911,13 @@ sub tmpdel {
return &reply("tmpdel:$token",$server);
}
-# ------------------------------------------------------------ get_timebased_id
+# ------------------------------------------------------------ get_timebased_id
sub get_timebased_id {
my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries,
$maxtries) = @_;
my ($newid,$error,$dellock);
- unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) {
+ unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) {
return ('','ok','invalid call to get suffix');
}
@@ -6034,7 +5931,7 @@ sub get_timebased_id {
if (!$maxtries) {
$maxtries = 10;
}
-
+
if (($cdom eq '') || ($cnum eq '')) {
if ($env{'request.course.id'}) {
$cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
@@ -6385,7 +6282,7 @@ sub usertools_access {
my ($toolstatus,$inststatus,$envkey);
if ($context eq 'requestauthor') {
- $envkey = $context;
+ $envkey = $context;
} else {
$envkey = $context.'.'.$tool;
}
@@ -6876,7 +6773,7 @@ sub allowed {
&& &is_portfolio_url($uri)) {
$thisallowed = &portfolio_access($uri);
}
-
+
# Full access at system, domain or course-wide level? Exit.
if ($thisallowed=~/F/) {
return 'F';
@@ -7463,9 +7360,9 @@ sub metadata_query {
my @server_list = (defined($server_array) ? @$server_array
: keys(%libserv) );
for my $server (@server_list) {
- my $domains = '';
+ my $domains = '';
if (ref($domains_hash) eq 'HASH') {
- $domains = $domains_hash->{$server};
+ $domains = $domains_hash->{$server};
}
unless ($custom or $customshow) {
my $reply=&reply("querysend:".&escape($query).':::'.&escape($domains),$server);
@@ -7996,7 +7893,7 @@ sub auto_validate_class_sec {
sub auto_crsreq_update {
my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,
- $code,$accessstart,$accessend,$inbound) = @_;
+ $code,$inbound) = @_;
my ($homeserver,%crsreqresponse);
if ($cdom =~ /^$match_domain$/) {
$homeserver = &domain($cdom,'primary');
@@ -8009,8 +7906,7 @@ sub auto_crsreq_update {
my $response=&reply('autocrsrequpdate:'.$cdom.':'.$cnum.':'.&escape($crstype).
':'.&escape($action).':'.&escape($ownername).':'.
&escape($ownerdomain).':'.&escape($fullname).':'.
- &escape($title).':'.&escape($code).':'.
- &escape($accessstart).':'.&escape($accessend).':'.$info,$homeserver);
+ &escape($title).':'.&escape($code).':'.$info,$homeserver);
unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
my @items = split(/&/,$response);
foreach my $item (@items) {
@@ -8290,7 +8186,7 @@ sub assignrole {
}
}
} elsif ($context eq 'requestauthor') {
- if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
+ if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
($url eq '/'.$udom.'/') && ($role eq 'au')) {
if ($env{'environment.requestauthor'} eq 'automatic') {
$refused = '';
@@ -8298,13 +8194,13 @@ sub assignrole {
my %domdefaults = &get_domain_defaults($udom);
if (ref($domdefaults{'requestauthor'}) eq 'HASH') {
my $checkbystatus;
- if ($env{'user.adv'}) {
+ if ($env{'user.adv'}) {
my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'};
if ($disposition eq 'automatic') {
$refused = '';
} elsif ($disposition eq '') {
$checkbystatus = 1;
- }
+ }
} else {
$checkbystatus = 1;
}
@@ -8391,7 +8287,7 @@ sub assignrole {
$context);
} elsif (($role eq 'ca') || ($role eq 'aa')) {
&coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
- $context);
+ $context);
}
if ($role eq 'cc') {
&autoupdate_coowners($url,$end,$start,$uname,$udom);
@@ -8706,7 +8602,7 @@ sub modifystudent {
# student's environment
$uid = undef if (!$forceid);
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
- $gene,$usec,$end,$start,$type,$locktype,
+ $gene,$usec,$end,$start,$type,$locktype,
$cid,$selfenroll,$context,$credits);
return $reply;
}
@@ -9851,7 +9747,7 @@ sub get_numsuppfiles {
unless ($chome eq 'no_host') {
($suppcount,my $errors) = (0,0);
my $suppmap = 'supplemental.sequence';
- ($suppcount,$errors) =
+ ($suppcount,$errors) =
&Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);
}
&do_cache_new('suppcount',$hashid,$suppcount,600);
@@ -10046,7 +9942,7 @@ sub EXT {
$courseid = $cid;
}
if (($symbparm && $courseid) &&
- (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid))) {
+ (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid))) {
#print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
@@ -10297,7 +10193,7 @@ sub metadata {
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
return undef;
}
- if (($uri =~ /^priv/ || $uri=~m{^home/httpd/html/priv})
+ if (($uri =~ /^priv/ || $uri=~/home\/httpd\/html\/priv/)
&& &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {
return undef;
}
@@ -10834,7 +10730,7 @@ sub symbverify {
$ids=$bighash{'ids_'.&clutter($thisurl)};
}
unless ($ids) {
- my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;
+ my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;
$ids=$bighash{$idkey};
}
if ($ids) {
@@ -10850,14 +10746,14 @@ sub symbverify {
if (ref($encstate)) {
$$encstate = $bighash{'encrypted_'.$id};
}
- if (($env{'request.role.adv'}) ||
- ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
+ if (($env{'request.role.adv'}) ||
+ ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
($thisurl eq '/adm/navmaps')) {
- $okay=1;
+ $okay=1;
last;
- }
- }
- }
+ }
+ }
+ }
}
untie(%bighash);
}
@@ -10930,14 +10826,18 @@ sub deversion {
sub symbread {
my ($thisfn,$donotrecurse)=@_;
- my $cache_str='request.symbread.cached.'.$thisfn;
- if (defined($env{$cache_str})) { return $env{$cache_str}; }
+ my $cache_str;
+ if ($thisfn ne '') {
+ $cache_str='request.symbread.cached.'.$thisfn;
+ if ($env{$cache_str} ne '') {
+ return $env{$cache_str};
+ }
+ } else {
# no filename provided? try from environment
- unless ($thisfn) {
if ($env{'request.symb'}) {
- return $env{$cache_str}=&symbclean($env{'request.symb'});
- }
- $thisfn=$env{'request.filename'};
+ return $env{$cache_str}=&symbclean($env{'request.symb'});
+ }
+ $thisfn=$env{'request.filename'};
}
if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
# is that filename actually a symb? Verify, clean, and return
@@ -11165,6 +11065,7 @@ sub rndseed {
$which =&get_rand_alg($courseid);
}
if (defined(&getCODE())) {
+
if ($which eq '64bit5') {
return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit4') {
@@ -11350,12 +11251,8 @@ sub rndseed_CODE_64bit5 {
sub setup_random_from_rndseed {
my ($rndseed)=@_;
if ($rndseed =~/([,:])/) {
- my ($num1,$num2) = map { abs($_); } (split(/[,:]/,$rndseed));
- if ((!$num1) || (!$num2) || ($num1 > 2147483562) || ($num2 > 2147483398)) {
- &Math::Random::random_set_seed_from_phrase($rndseed);
- } else {
- &Math::Random::random_set_seed($num1,$num2);
- }
+ my ($num1,$num2)=split(/[,:]/,$rndseed);
+ &Math::Random::random_set_seed(abs($num1),abs($num2));
} else {
&Math::Random::random_set_seed_from_phrase($rndseed);
}
@@ -11746,9 +11643,7 @@ sub default_login_domain {
sub declutter {
my $thisfn=shift;
if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
- unless ($thisfn=~m{^/home/httpd/html/priv/}) {
- $thisfn=~s{^/home/httpd/html}{};
- }
+ $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
$thisfn=~s/^\///;
$thisfn=~s|^adm/wrapper/||;
$thisfn=~s|^adm/coursedocs/showdoc/||;
@@ -11875,7 +11770,7 @@ sub get_dns {
$alldns{$host} = $protocol;
}
while (%alldns) {
- my ($dns) = sort { $b cmp $a } keys(%alldns);
+ my ($dns) = keys(%alldns);
my $ua=new LWP::UserAgent;
$ua->timeout(30);
my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
@@ -11883,9 +11778,9 @@ sub get_dns {
delete($alldns{$dns});
next if ($response->is_error());
my @content = split("\n",$response->content);
- unless ($nocache) {
+ unless ($nocache) {
&do_cache_new('dns',$url,\@content,30*24*60*60);
- }
+ }
&$func(\@content,$hashref);
return;
}
@@ -11901,35 +11796,16 @@ sub get_dns {
# ------------------------------------------------------Get DNS checksums file
sub parse_dns_checksums_tab {
my ($lines,$hashref) = @_;
- my $lonhost = $perlvar{'lonHostID'};
- my $machine_dom = &Apache::lonnet::host_domain($lonhost);
+ my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
my $loncaparev = &get_server_loncaparev($machine_dom);
- my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];
- my $webconfdir = '/etc/httpd/conf';
- if ($distro =~ /^(ubuntu|debian)(\d+)$/) {
- $webconfdir = '/etc/apache2';
- } elsif ($distro =~ /^sles(\d+)$/) {
- if ($1 >= 10) {
- $webconfdir = '/etc/apache2';
- }
- } elsif ($distro =~ /^suse(\d+\.\d+)$/) {
- if ($1 >= 10.0) {
- $webconfdir = '/etc/apache2';
- }
- }
my ($release,$timestamp) = split(/\-/,$loncaparev);
my (%chksum,%revnum);
if (ref($lines) eq 'ARRAY') {
chomp(@{$lines});
my $version = shift(@{$lines});
- if ($version eq $release) {
+ if ($version eq $release) {
foreach my $line (@{$lines}) {
my ($file,$version,$shasum) = split(/,/,$line);
- if ($file =~ m{^/etc/httpd/conf}) {
- if ($webconfdir eq '/etc/apache2') {
- $file =~ s{^\Q/etc/httpd/conf/\E}{$webconfdir/};
- }
- }
$chksum{$file} = $shasum;
$revnum{$file} = $version;
}
@@ -11947,7 +11823,7 @@ sub parse_dns_checksums_tab {
sub fetch_dns_checksums {
my %checksums;
my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
- my $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'});
+ my $loncaparev = &get_server_loncaparev($machine_dom);
my ($release,$timestamp) = split(/\-/,$loncaparev);
&get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,
\%checksums);
@@ -12330,9 +12206,9 @@ sub all_loncaparevs {
return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10 2.11);
}
-# ------------------------------------------------------- Read loncaparev table
+# ---------------------------------------------------------- Read loncaparev table
{
- sub load_loncaparevs {
+ sub load_loncaparevs {
if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {
if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {
while (my $configline=<$config>) {
@@ -12346,7 +12222,7 @@ sub all_loncaparevs {
}
}
-# ----------------------------------------------------- Read serverhostID table
+# ---------------------------------------------------------- Read serverhostID table
{
sub load_serverhomeIDs {
if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {
@@ -12438,11 +12314,11 @@ BEGIN {
close($config);
}
-# --------------------------------------------------------- Read loncaparev table
+# ---------------------------------------------------------- Read loncaparev table
&load_loncaparevs();
-# ------------------------------------------------------- Read serverhostID table
+# ---------------------------------------------------------- Read serverhostID table
&load_serverhomeIDs();
@@ -12840,9 +12716,9 @@ provided for types, will default to retu
=item *
in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if
-user: $uname:$udom has a role in the course: $cdom_$cnum.
+user: $uname:$udom has a role in the course: $cdom_$cnum.
-Additional optional arguments are: $type (if role checking is to be restricted
+Additional optional arguments are: $type (if role checking is to be restricted
to certain user status types -- previous (expired roles), active (currently
available roles) or future (roles available in the future), and
$hideprivileged -- if true will not report course roles for users who
@@ -13079,7 +12955,7 @@ values that are the resource value. I b
versions are also returned.
get_numsuppfiles($cnum,$cdom) : retrieve number of files in a course's
-supplemental content area. This routine caches the number of files for
+supplemental content area. This routine caches the number of files for
10 minutes.
=back
@@ -13192,9 +13068,9 @@ and is a possible symb for the URL in $t
resource that the user accessed using /enc/ returns a 1 on success, 0
on failure, user must be in a course, as it assumes the existence of
the course initial hash, and uses $env('request.course.id'}. The third
-arg is an optional reference to a scalar. If this arg is passed in the
+arg is an optional reference to a scalar. If this arg is passed in the
call to symbverify, it will be set to 1 if the symb has been set to be
-encrypted; otherwise it will be null.
+encrypted; otherwise it will be null.
=item *
@@ -13247,13 +13123,13 @@ expirespread($uname,$udom,$stype,$usymb)
devalidate($symb) : devalidate temporary spreadsheet calculations,
forcing spreadsheet to reevaluate the resource scores next time.
-=item *
+=item *
can_edit_resource($file,$cnum,$cdom,$resurl,$symb,$group) : determine if current user can edit a particular resource,
when viewing in course context.
input: six args -- filename (decluttered), course number, course domain,
- url, symb (if registered) and group (if this is a
+ url, symb (if registered) and group (if this is a
group item -- e.g., bulletin board, group page etc.).
output: array of five scalars --
@@ -13261,15 +13137,15 @@ when viewing in course context.
$home -- homeserver of resource (i.e., for author if published,
or course if uploaded.).
$switchserver -- 1 if server switch will be needed.
- $forceedit -- 1 if icon/link should be to go to edit mode
+ $forceedit -- 1 if icon/link should be to go to edit mode
$forceview -- 1 if icon/link should be to go to view mode
=item *
is_course_upload($file,$cnum,$cdom)
-Used in course context to determine if current file was uploaded to
-the course (i.e., would be found in /userfiles/docs on the course's
+Used in course context to determine if current file was uploaded to
+the course (i.e., would be found in /userfiles/docs on the course's
homeserver.
input: 3 args -- filename (decluttered), course number and course domain.
@@ -13427,7 +13303,7 @@ server ($udom and $uhome are optional)
=item *
-get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults
+get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults
for: authentication, language, quotas, timezone, date locale, and portal URL in
the target domain.
@@ -13482,7 +13358,8 @@ for course's uploaded content.
=over
=item
-canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, communityquota, textbookquota
+canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota,
+communityquota, textbookquota
=back
@@ -13492,7 +13369,7 @@ on your servers.
=over
-=item
+=item
remotesessions, hostedsessions
=back
@@ -13500,10 +13377,10 @@ remotesessions, hostedsessions
=back
In cases where a domain coordinator has never used the "Set Domain Configuration"
-utility to create a configuration.db file on a domain's primary library server
+utility to create a configuration.db file on a domain's primary library server
only the following domain defaults: auth_def, auth_arg_def, lang_def
-- corresponding values are authentication type (internal, krb4, krb5,
-or localauth), initial password or a kerberos realm, language (e.g., en-us) --
+or localauth), initial password or a kerberos realm, language (e.g., en-us) --
will be available. Values are retrieved from cache (if current), unless the
optional $ignore_cache arg is true, or from domain's configuration.db (if available),
or lastly from values in lonTabs/dns_domain,tab, or lonTabs/domain.tab.
@@ -13735,8 +13612,7 @@ filelocation except for hrefs
=item *
-declutter() : declutters URLs -- remove beginning slashes, 'res' etc.
-also removes beginning /home/httpd/html unless /priv/ follows it.
+declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)
=back
@@ -13931,8 +13807,8 @@ Returns:
get_timebased_id():
-Attempts to get a unique timestamp-based suffix for use with items added to a
-course via the Course Editor (e.g., folders, composite pages,
+Attempts to get a unique timestamp-based suffix for use with items added to a
+course via the Course Editor (e.g., folders, composite pages,
group bulletin boards).
Args: (first three required; six others optional)
@@ -13943,24 +13819,24 @@ Args: (first three required; six others
2. keyid (alphanumeric): name of temporary locking key in hash,
e.g., num, boardids
-3. namespace: name of gdbm file used to store suffixes already assigned;
+3. namespace: name of gdbm file used to store suffixes already assigned;
file will be named nohist_namespace.db
4. cdom: domain of course; default is current course domain from %env
5. cnum: course number; default is current course number from %env
-6. idtype: set to concat if an additional digit is to be appended to the
+6. idtype: set to concat if an additional digit is to be appended to the
unix timestamp to form the suffix, if the plain timestamp is already
- in use. Default is to not do this, but simply increment the unix
+ in use. Default is to not do this, but simply increment the unix
timestamp by 1 until a unique key is obtained.
7. who: holder of locking key; defaults to user:domain for user.
-8. locktries: number of attempts to obtain a lock (sleep of 1s before
+8. locktries: number of attempts to obtain a lock (sleep of 1s before
retrying); default is 3.
-9. maxtries: number of attempts to obtain a unique suffix; default is 20.
+9. maxtries: number of attempts to obtain a unique suffix; default is 20.
Returns:
500 Internal Server Error
Internal Server Error
The server encountered an internal error or
misconfiguration and was unable to complete
your request.
Please contact the server administrator at
root@localhost to inform them of the time this error occurred,
and the actions you performed just before this error.
More information about this error may be available
in the server error log.