--- loncom/lonnet/perl/lonnet.pm 2013/07/31 17:37:18 1.1232
+++ loncom/lonnet/perl/lonnet.pm 2014/01/03 18:39:48 1.1248
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1232 2013/07/31 17:37:18 raeburn Exp $
+# $Id: lonnet.pm,v 1.1248 2014/01/03 18:39:48 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -78,7 +78,7 @@ use Image::Magick;
use Encode;
-use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $apache
+use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
%managerstab);
@@ -356,8 +356,11 @@ sub get_remote_globals {
}
sub remote_devalidate_cache {
- my ($lonhost,$name,$id) = @_;
- my $response = &reply('devalidatecache:'.&escape($name).':'.&escape($id),$lonhost);
+ my ($lonhost,$cachekeys) = @_;
+ my $items;
+ return unless (ref($cachekeys) eq 'ARRAY');
+ my $cachestr = join('&',@{$cachekeys});
+ my $response = &reply('devalidatecache:'.&escape($cachestr),$lonhost);
return $response;
}
@@ -603,7 +606,7 @@ sub transfer_profile_to_env {
# ---------------------------------------------------- Check for valid session
sub check_for_valid_session {
- my ($r,$name) = @_;
+ my ($r,$name,$userhashref) = @_;
my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
if ($name eq '') {
$name = 'lonID';
@@ -634,13 +637,12 @@ sub check_for_valid_session {
|| !defined($disk_env{'user.domain'})) {
return undef;
}
- if (($r->user() eq '') && ($apache >= 2.4)) {
- if ($disk_env{'user.domain'} eq $r->dir_config('lonDefDomain')) {
- $r->user($disk_env{'user.name'});
- } else {
- $r->user($disk_env{'user.name'}.':'.$disk_env{'user.domain'});
- }
+
+ if (ref($userhashref) eq 'HASH') {
+ $userhashref->{'name'} = $disk_env{'user.name'};
+ $userhashref->{'domain'} = $disk_env{'user.domain'};
}
+
return $handle;
}
@@ -1323,7 +1325,7 @@ sub check_loadbalancing {
}
}
} elsif (($homeintdom) && ($udom ne $serverhomedom)) {
- my ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);
+ ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);
unless (defined($cached)) {
my %domconfig =
&Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);
@@ -1984,12 +1986,15 @@ sub inst_userrules {
# ------------- Get Authentication, Language and User Tools Defaults for Domain
sub get_domain_defaults {
- my ($domain) = @_;
+ my ($domain,$ignore_cache) = @_;
+ return if (($domain eq '') || ($domain eq 'public'));
my $cachetime = 60*60*24;
- my ($result,$cached)=&is_cached_new('domdefaults',$domain);
- if (defined($cached)) {
- if (ref($result) eq 'HASH') {
- return %{$result};
+ unless ($ignore_cache) {
+ my ($result,$cached)=&is_cached_new('domdefaults',$domain);
+ if (defined($cached)) {
+ if (ref($result) eq 'HASH') {
+ return %{$result};
+ }
}
}
my %domdefaults;
@@ -2027,7 +2032,7 @@ sub get_domain_defaults {
}
}
if (ref($domconfig{'requestcourses'}) eq 'HASH') {
- foreach my $item ('official','unofficial','community') {
+ foreach my $item ('official','unofficial','community','textbook') {
$domdefaults{$item} = $domconfig{'requestcourses'}{$item};
}
}
@@ -2044,11 +2049,13 @@ sub get_domain_defaults {
if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
$domdefaults{'officialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'official'};
$domdefaults{'unofficialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'unofficial'};
+ $domdefaults{'textbookcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'textbook'};
}
if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
$domdefaults{'officialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'official'};
$domdefaults{'unofficialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'unofficial'};
- $domdefaults{'communityquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'community'};
+ $domdefaults{'communityquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'community'};
+ $domdefaults{'textbookquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'textbook'};
}
}
if (ref($domconfig{'usersessions'}) eq 'HASH') {
@@ -2852,6 +2859,13 @@ sub can_edit_resource {
$cfile =~ s{^http://}{};
$cfile = '/adm/wrapper/ext/'.$cfile;
}
+ } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
+ if ($env{'form.forceedit'}) {
+ $forceview = 1;
+ } else {
+ $forceedit = 1;
+ }
+ $cfile = ($resurl =~ m{^/} ? $resurl : "/$resurl");
}
}
if ($uploaded || $incourse) {
@@ -3489,8 +3503,26 @@ sub extract_embedded_items {
}
}
}
+ if (lc($tagname) eq 'iframe') {
+ my $src = $attr->{'src'} ;
+ if (($src ne '') && ($src !~ m{^(/|https?://)})) {
+ &add_filetype($allfiles,$src,'src');
+ } elsif ($src =~ m{^/}) {
+ if ($env{'request.course.id'}) {
+ my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+ my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+ my $url = &hreflocation('',$fullpath);
+ if ($url =~ m{^/uploaded/$cdom/$cnum/docs/(\w+/\d+)/}) {
+ my $relpath = $1;
+ if ($src =~ m{^/uploaded/$cdom/$cnum/docs/\Q$relpath\E/(.+)$}) {
+ &add_filetype($allfiles,$1,'src');
+ }
+ }
+ }
+ }
+ }
if ($t->[4] =~ m{/>$}) {
- pop(@state);
+ pop(@state);
}
} elsif ($t->[0] eq 'E') {
my ($tagname) = ($t->[1]);
@@ -4147,7 +4179,8 @@ sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
$selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
- $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_;
+ $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner,
+ $hasuniquecode)=@_;
my $as_hash = 1;
my %returnhash;
if (!$domfilter) { $domfilter=''; }
@@ -4170,7 +4203,7 @@ sub courseiddump {
&escape($catfilter), $showhidden, $caller,
&escape($cloner), &escape($cc_clone), $cloneonly,
&escape($createdbefore), &escape($createdafter),
- &escape($creationcontext), $domcloner)));
+ &escape($creationcontext), $domcloner, $hasuniquecode)));
} else {
$rep = &reply('courseiddump:'.&host_domain($tryserver).':'.
$sincefilter.':'.&escape($descfilter).':'.
@@ -4181,7 +4214,7 @@ sub courseiddump {
$showhidden.':'.$caller.':'.&escape($cloner).':'.
&escape($cc_clone).':'.$cloneonly.':'.
&escape($createdbefore).':'.&escape($createdafter).':'.
- &escape($creationcontext).':'.$domcloner,
+ &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode,
$tryserver);
}
@@ -6177,6 +6210,7 @@ sub usertools_access {
official => 1,
unofficial => 1,
community => 1,
+ textbook => 1,
);
} elsif ($context eq 'requestauthor') {
%tools = (
@@ -6192,7 +6226,7 @@ sub usertools_access {
}
return if (!defined($tools{$tool}));
- if ((!defined($udom)) || (!defined($uname))) {
+ if (($udom eq '') || ($uname eq '')) {
$udom = $env{'user.domain'};
$uname = $env{'user.name'};
}
@@ -7283,19 +7317,23 @@ sub definerole {
# ---------------- Make a metadata query against the network of library servers
sub metadata_query {
- my ($query,$custom,$customshow,$server_array)=@_;
+ my ($query,$custom,$customshow,$server_array,$domains_hash)=@_;
my %rhash;
my %libserv = &all_library();
my @server_list = (defined($server_array) ? @$server_array
: keys(%libserv) );
for my $server (@server_list) {
+ my $domains = '';
+ if (ref($domains_hash) eq 'HASH') {
+ $domains = $domains_hash->{$server};
+ }
unless ($custom or $customshow) {
- my $reply=&reply("querysend:".&escape($query),$server);
+ my $reply=&reply("querysend:".&escape($query).':::'.&escape($domains),$server);
$rhash{$server}=$reply;
}
else {
my $reply=&reply("querysend:".&escape($query).':'.
- &escape($custom).':'.&escape($customshow),
+ &escape($custom).':'.&escape($customshow).':'.&escape($domains),
$server);
$rhash{$server}=$reply;
}
@@ -7813,6 +7851,33 @@ sub auto_validate_class_sec {
return $response;
}
+sub auto_crsreq_update {
+ my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,
+ $code,$inbound) = @_;
+ my ($homeserver,%crsreqresponse);
+ if ($cdom =~ /^$match_domain$/) {
+ $homeserver = &domain($cdom,'primary');
+ }
+ unless (($homeserver eq 'no_host') || ($homeserver eq '')) {
+ my $info;
+ if (ref($inbound) eq 'HASH') {
+ $info = &freeze_escape($inbound);
+ }
+ my $response=&reply('autocrsrequpdate:'.$cdom.':'.$cnum.':'.&escape($crstype).
+ ':'.&escape($action).':'.&escape($ownername).':'.
+ &escape($ownerdomain).':'.&escape($fullname).':'.
+ &escape($title).':'.&escape($code).':'.$info,$homeserver);
+ unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
+ my @items = split(/&/,$response);
+ foreach my $item (@items) {
+ my ($key,$value) = split('=',$item);
+ $crsreqresponse{&unescape($key)} = &thaw_unescape($value);
+ }
+ }
+ }
+ return \%crsreqresponse;
+}
+
# ------------------------------------------------------- Course Group routines
sub get_coursegroups {
@@ -8494,7 +8559,7 @@ sub modifystudent {
$desiredhome,$email,$inststatus);
unless ($reply eq 'ok') { return $reply; }
# This will cause &modify_student_enrollment to get the uid from the
- # students environment
+ # student's environment
$uid = undef if (!$forceid);
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
$gene,$usec,$end,$start,$type,$locktype,
@@ -9630,6 +9695,26 @@ sub resdata {
return undef;
}
+sub get_numsuppfiles {
+ my ($cnum,$cdom,$ignorecache)=@_;
+ my $hashid=$cnum.':'.$cdom;
+ my ($suppcount,$cached);
+ unless ($ignorecache) {
+ ($suppcount,$cached) = &is_cached_new('suppcount',$hashid);
+ }
+ unless (defined($cached)) {
+ my $chome=&homeserver($cnum,$cdom);
+ unless ($chome eq 'no_host') {
+ ($suppcount,my $errors) = (0,0);
+ my $suppmap = 'supplemental.sequence';
+ ($suppcount,$errors) =
+ &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);
+ }
+ &do_cache_new('suppcount',$hashid,$suppcount,600);
+ }
+ return $suppcount;
+}
+
#
# EXT resource caching routines
#
@@ -9793,21 +9878,21 @@ sub EXT {
}
return &hreflocation('',$env{'request.filename'});
}
- }
- if ((defined($courseid)) && ($courseid eq $env{'request.course.id'}) && $symbparm) {
- if ($space eq 'visibleparts') {
- my $navmap = Apache::lonnavmaps::navmap->new();
- my $item;
- if (ref($navmap)) {
- my $res = $navmap->getBySymb($symbparm);
- my $parts = $res->parts();
- if (ref($parts) eq 'ARRAY') {
- $item = join(',',@{$parts});
+ if ((defined($courseid)) && ($courseid eq $env{'request.course.id'}) && $symbparm) {
+ if ($space eq 'visibleparts') {
+ my $navmap = Apache::lonnavmaps::navmap->new();
+ my $item;
+ if (ref($navmap)) {
+ my $res = $navmap->getBySymb($symbparm);
+ my $parts = $res->parts();
+ if (ref($parts) eq 'ARRAY') {
+ $item = join(',',@{$parts});
+ }
+ undef($navmap);
}
- undef($navmap);
+ return $item;
}
- return $item;
}
}
@@ -11677,30 +11762,12 @@ sub parse_dns_checksums_tab {
my (%chksum,%revnum);
if (ref($lines) eq 'ARRAY') {
chomp(@{$lines});
- my $versions = shift(@{$lines});
- my %supported;
- if ($versions =~ /^VERSIONS\:([\w\.\,]+)$/) {
- my $releaseslist = $1;
- if ($releaseslist =~ /,/) {
- map { $supported{$_} = 1; } split(/,/,$releaseslist);
- } elsif ($releaseslist) {
- $supported{$releaseslist} = 1;
- }
- }
- if ($supported{$release}) {
- my $matchthis = 0;
+ my $version = shift(@{$lines});
+ if ($version eq $release) {
foreach my $line (@{$lines}) {
- if ($line =~ /^(\d[\w\.]+)$/) {
- if ($matchthis) {
- last;
- } elsif ($1 eq $release) {
- $matchthis = 1;
- }
- } elsif ($matchthis) {
- my ($file,$version,$shasum) = split(/,/,$line);
- $chksum{$file} = $shasum;
- $revnum{$file} = $version;
- }
+ my ($file,$version,$shasum) = split(/,/,$line);
+ $chksum{$file} = $shasum;
+ $revnum{$file} = $version;
}
if (ref($hashref) eq 'HASH') {
%{$hashref} = (
@@ -11714,8 +11781,11 @@ sub parse_dns_checksums_tab {
}
sub fetch_dns_checksums {
- my %checksums;
- &get_dns('/adm/dns/checksums',\&parse_dns_checksums_tab,1,1,
+ my %checksums;
+ my $machine_dom = &Apache::lonnet::host_domain($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);
return \%checksums;
}
@@ -12271,17 +12341,6 @@ $readit=1;
if ($test != 0) { $_64bit=1; } else { $_64bit=0; }
&logthis(" Detected 64bit platform ($_64bit)");
}
-
- {
- eval {
- ($apache) =
- (Apache2::ServerUtil::get_server_version() =~ m{Apache/(\d+\.\d+)});
- };
- if ($@) {
- $apache = 1.3;
- }
- }
-
}
}
@@ -12690,8 +12749,8 @@ or when Autoupdate.pl is run by cron in
modifystudent
modify a student's enrollment and identification information.
-The course id is resolved based on the current users environment.
-This means the envoking user must be a course coordinator or otherwise
+The course id is resolved based on the current user's environment.
+This means the invoking user must be a course coordinator or otherwise
associated with a course.
This call is essentially a wrapper for lonnet::modifyuser and
@@ -12751,20 +12810,20 @@ Inputs:
modify_student_enrollment
-Change a students enrollment status in a class. The environment variable
+Change a student's enrollment status in a class. The environment variable
'role.request.course' must be defined for this function to proceed.
Inputs:
=over 4
-=item $udom, students domain
+=item $udom, student's domain
-=item $uname, students name
+=item $uname, student's name
-=item $uid, students user id
+=item $uid, student's user id
-=item $first, students first name
+=item $first, student's first name
=item $middle
@@ -12846,7 +12905,7 @@ If defined, the supplied username is use
resdata($name,$domain,$type,@which) : request for current parameter
setting for a specific $type, where $type is either 'course' or 'user',
@what should be a list of parameters to ask about. This routine caches
-answers for 5 minutes.
+answers for 10 minutes.
=item *
@@ -12855,6 +12914,10 @@ data base, returning a hash that is keye
values that are the resource value. I believe that the timestamps and
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
+10 minutes.
+
=back
=head2 Course Modification
@@ -13200,15 +13263,91 @@ server ($udom and $uhome are optional)
=item *
-get_domain_defaults($target_domain) : returns hash with defaults for
-authentication and language in the domain. Keys are: auth_def, auth_arg_def,
-lang_def; corresponsing values are authentication type (internal, krb4, krb5,
-or localauth), initial password or a kerberos realm, language (e.g., en-us).
-Values are retrieved from cache (if current), or from domain's configuration.db
-(if available), or lastly from values in lonTabs/dns_domain,tab,
-or lonTabs/domain.tab.
+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.
+
+May also include additional key => value pairs for the following groups:
+
+=over
+
+=item
+disk quotas (MB allocated by default to portfolios and authoring spaces).
+
+=over
+
+=item defaultquota, authorquota
+
+=back
+
+=item
+tools (availability of aboutme page, blog, webDAV access for authoring spaces,
+portfolio for users).
+
+=over
+
+=item
+aboutme, blog, webdav, portfolio
+
+=back
+
+=item
+requestcourses: ability to request courses, and how requests are processed.
+
+=over
+
+=item
+official, unofficial, community, textbook
+
+=back
+
+=item
+inststatus: types of institutional affiliation, and order in which they are displayed.
+
+=over
+
+=item
+inststatustypes, inststatusorder
+
+=back
+
+=item
+coursedefaults: can PDF forms can be created, default credits for courses, default quotas (MB)
+for course's uploaded content.
+
+=over
+
+=item
+canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota,
+communityquota, textbookquota
+
+=back
+
+=item
+usersessions: set options for hosting of your users in other domains, and hosting of users from other domains
+on your servers.
+
+=over
+
+=item
+remotesessions, hostedsessions
+
+=back
+
+=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
+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) --
+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.
+
+Typical usage:
-%domdefaults = &get_auth_defaults($target_domain);
+%domdefaults = &get_domain_defaults($target_domain);
=back