--- loncom/lonnet/perl/lonnet.pm 2010/11/10 14:44:19 1.1093
+++ loncom/lonnet/perl/lonnet.pm 2011/08/09 01:06:33 1.1128
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1093 2010/11/10 14:44:19 raeburn Exp $
+# $Id: lonnet.pm,v 1.1128 2011/08/09 01:06:33 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -95,6 +95,7 @@ use Math::Random;
use File::MMagic;
use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;
+
use File::Copy;
my $readit;
@@ -196,6 +197,29 @@ sub get_server_timezone {
}
}
+sub get_server_distarch {
+ my ($lonhost,$ignore_cache) = @_;
+ if (defined($lonhost)) {
+ if (!defined(&hostname($lonhost))) {
+ return;
+ }
+ my $cachetime = 12*3600;
+ if (!$ignore_cache) {
+ my ($distarch,$cached)=&is_cached_new('serverdistarch',$lonhost);
+ if (defined($cached)) {
+ return $distarch;
+ }
+ }
+ my $rep = &reply('serverdistarch',$lonhost);
+ unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' ||
+ $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||
+ $rep eq '') {
+ return &do_cache_new('serverdistarch',$lonhost,$rep,$cachetime);
+ }
+ }
+ return;
+}
+
sub get_server_loncaparev {
my ($dom,$lonhost,$ignore_cache,$caller) = @_;
if (defined($lonhost)) {
@@ -282,6 +306,52 @@ sub get_server_homeID {
return &do_cache_new('serverhomeID',$hostname,$serverhomeID,$cachetime);
}
+sub get_remote_globals {
+ my ($lonhost,$whathash,$ignore_cache) = @_;
+ my ($result,%returnhash,%whatneeded);
+ if (ref($whathash) eq 'HASH') {
+ foreach my $what (sort(keys(%{$whathash}))) {
+ my $hashid = $lonhost.'-'.$what;
+ my ($response,$cached);
+ unless ($ignore_cache) {
+ ($response,$cached)=&is_cached_new('lonnetglobal',$hashid);
+ }
+ if (defined($cached)) {
+ $returnhash{$what} = $response;
+ } else {
+ $whatneeded{$what} = 1;
+ }
+ }
+ if (keys(%whatneeded) == 0) {
+ $result = 'ok';
+ } else {
+ my $requested = &freeze_escape(\%whatneeded);
+ my $rep=&reply('readlonnetglobal:'.$requested,$lonhost);
+ if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||
+ ($rep eq 'unknown_cmd')) {
+ $result = $rep;
+ } else {
+ $result = 'ok';
+ my @pairs=split(/\&/,$rep);
+ foreach my $item (@pairs) {
+ my ($key,$value)=split(/=/,$item,2);
+ my $what = &unescape($key);
+ my $hashid = $lonhost.'-'.$what;
+ $returnhash{$what}=&thaw_unescape($value);
+ &do_cache_new('lonnetglobal',$hashid,$returnhash{$what},600);
+ }
+ }
+ }
+ }
+ return ($result,\%returnhash);
+}
+
+sub remote_devalidate_cache {
+ my ($lonhost,$name,$id) = @_;
+ my $response = &reply('devalidatecache',&escape($name).':'.&escape($id),$lonhost);
+ return $response;
+}
+
# -------------------------------------------------- Non-critical communication
sub subreply {
my ($cmd,$server)=@_;
@@ -612,11 +682,20 @@ sub appenv {
# ----------------------------------------------------- Delete from Environment
sub delenv {
- my ($delthis,$regexp) = @_;
- if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
- &logthis("<font color=\"blue\">WARNING: ".
- "Attempt to delete from environment ".$delthis);
- return 'error';
+ my ($delthis,$regexp,$roles) = @_;
+ if (($delthis=~/^user\.role/) || ($delthis=~/^user\.priv/)) {
+ my $refused = 1;
+ if (ref($roles) eq 'ARRAY') {
+ my ($type,$role) = ($delthis =~ /^user\.(role|priv)\.([^.]+)\./);
+ if (grep(/^\Q$role\E$/,@{$roles})) {
+ $refused = 0;
+ }
+ }
+ if ($refused) {
+ &logthis("<font color=\"blue\">WARNING: ".
+ "Attempt to delete from environment ".$delthis);
+ return 'error';
+ }
}
my $opened = open(my $env_file,'+<',$env{'user.environment'});
if ($opened
@@ -740,26 +819,33 @@ sub spareserver {
my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom);
$remotesessions = $udomdefaults{'remotesessions'};
}
- foreach my $try_server (@{ $spareid{'primary'} }) {
- if ($uint_dom) {
- next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
- $try_server));
+ my $spareshash = &this_host_spares($udom);
+ if (ref($spareshash) eq 'HASH') {
+ if (ref($spareshash->{'primary'}) eq 'ARRAY') {
+ foreach my $try_server (@{ $spareshash->{'primary'} }) {
+ if ($uint_dom) {
+ next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
+ $try_server));
+ }
+ ($spare_server, $lowest_load) =
+ &compare_server_load($try_server, $spare_server, $lowest_load);
+ }
}
- ($spare_server, $lowest_load) =
- &compare_server_load($try_server, $spare_server, $lowest_load);
- }
-
- my $found_server = ($spare_server ne '' && $lowest_load < 100);
- if (!$found_server) {
- foreach my $try_server (@{ $spareid{'default'} }) {
- if ($uint_dom) {
- next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
- $try_server));
- }
- ($spare_server, $lowest_load) =
- &compare_server_load($try_server, $spare_server, $lowest_load);
- }
+ my $found_server = ($spare_server ne '' && $lowest_load < 100);
+
+ if (!$found_server) {
+ if (ref($spareshash->{'default'}) eq 'ARRAY') {
+ foreach my $try_server (@{ $spareshash->{'default'} }) {
+ if ($uint_dom) {
+ next unless (&spare_can_host($udom,$uint_dom,
+ $remotesessions,$try_server));
+ }
+ ($spare_server, $lowest_load) =
+ &compare_server_load($try_server, $spare_server, $lowest_load);
+ }
+ }
+ }
}
if (!$want_server_name) {
@@ -784,7 +870,7 @@ sub compare_server_load {
my $userloadans = &reply('userload',$try_server);
if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
- return; #didn't get a number from the server
+ return ($spare_server, $lowest_load); #didn't get a number from the server
}
my $load;
@@ -810,9 +896,18 @@ sub compare_server_load {
# --------------------------- ask offload servers if user already has a session
sub find_existing_session {
my ($udom,$uname) = @_;
- foreach my $try_server (@{ $spareid{'primary'} },
- @{ $spareid{'default'} }) {
- return $try_server if (&has_user_session($try_server, $udom, $uname));
+ my $spareshash = &this_host_spares($udom);
+ if (ref($spareshash) eq 'HASH') {
+ if (ref($spareshash->{'primary'}) eq 'ARRAY') {
+ foreach my $try_server (@{ $spareshash->{'primary'} }) {
+ return $try_server if (&has_user_session($try_server, $udom, $uname));
+ }
+ }
+ if (ref($spareshash->{'default'}) eq 'ARRAY') {
+ foreach my $try_server (@{ $spareshash->{'default'} }) {
+ return $try_server if (&has_user_session($try_server, $udom, $uname));
+ }
+ }
}
return;
}
@@ -830,22 +925,38 @@ sub has_user_session {
# --------- determine least loaded server in a user's domain which allows login
sub choose_server {
- my ($udom) = @_;
+ my ($udom,$checkloginvia) = @_;
my %domconfhash = &Apache::loncommon::get_domainconf($udom);
my %servers = &get_servers($udom);
my $lowest_load = 30000;
- my ($login_host,$hostname);
+ my ($login_host,$hostname,$portal_path);
foreach my $lonhost (keys(%servers)) {
- my $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
- if ($loginvia eq '') {
+ my $loginvia;
+ if ($checkloginvia) {
+ $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
+ if ($loginvia) {
+ my ($server,$path) = split(/:/,$loginvia);
+ ($login_host, $lowest_load) =
+ &compare_server_load($server, $login_host, $lowest_load);
+ if ($login_host eq $server) {
+ $portal_path = $path;
+ }
+ } else {
+ ($login_host, $lowest_load) =
+ &compare_server_load($lonhost, $login_host, $lowest_load);
+ if ($login_host eq $lonhost) {
+ $portal_path = '';
+ }
+ }
+ } else {
($login_host, $lowest_load) =
- &compare_server_load($lonhost, $login_host, $lowest_load);
+ &compare_server_load($lonhost, $login_host, $lowest_load);
}
}
if ($login_host ne '') {
- $hostname = $servers{$login_host};
+ $hostname = &hostname($login_host);
}
- return ($login_host,$hostname);
+ return ($login_host,$hostname,$portal_path);
}
# --------------------------------------------- Try to change a user's password
@@ -986,15 +1097,19 @@ sub can_host_session {
}
if ($canhost) {
if (ref($hostedsessions) eq 'HASH') {
+ my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
+ my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {
- if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'excludedomain'}})) {
+ if (($uint_dom ne '') &&
+ (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) {
$canhost = 0;
} else {
$canhost = 1;
}
}
if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') {
- if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'includedomain'}})) {
+ if (($uint_dom ne '') &&
+ (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'includedomain'}}))) {
$canhost = 1;
} else {
$canhost = 0;
@@ -1025,6 +1140,84 @@ sub spare_can_host {
return $canhost;
}
+sub this_host_spares {
+ my ($dom) = @_;
+ my ($dom_in_use,$lonhost_in_use,$result);
+ my @hosts = ¤t_machine_ids();
+ foreach my $lonhost (@hosts) {
+ if (&host_domain($lonhost) eq $dom) {
+ $dom_in_use = $dom;
+ $lonhost_in_use = $lonhost;
+ last;
+ }
+ }
+ if ($dom_in_use ne '') {
+ $result = &spares_for_offload($dom_in_use,$lonhost_in_use);
+ }
+ if (ref($result) ne 'HASH') {
+ $lonhost_in_use = $perlvar{'lonHostID'};
+ $dom_in_use = &host_domain($lonhost_in_use);
+ $result = &spares_for_offload($dom_in_use,$lonhost_in_use);
+ if (ref($result) ne 'HASH') {
+ $result = \%spareid;
+ }
+ }
+ return $result;
+}
+
+sub spares_for_offload {
+ my ($dom_in_use,$lonhost_in_use) = @_;
+ my ($result,$cached)=&is_cached_new('spares',$dom_in_use);
+ if (defined($cached)) {
+ return $result;
+ } else {
+ my $cachetime = 60*60*24;
+ my %domconfig =
+ &Apache::lonnet::get_dom('configuration',['usersessions'],$dom_in_use);
+ if (ref($domconfig{'usersessions'}) eq 'HASH') {
+ if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') {
+ if (ref($domconfig{'usersessions'}{'spares'}{$lonhost_in_use}) eq 'HASH') {
+ return &do_cache_new('spares',$dom_in_use,$domconfig{'usersessions'}{'spares'}{$lonhost_in_use},$cachetime);
+ }
+ }
+ }
+ }
+ return;
+}
+
+sub internet_dom_servers {
+ my ($dom) = @_;
+ my (%uniqservers,%servers);
+ my $primaryserver = &hostname(&domain($dom,'primary'));
+ my @machinedoms = &machine_domains($primaryserver);
+ foreach my $mdom (@machinedoms) {
+ my %currservers = %servers;
+ my %server = &get_servers($mdom);
+ %servers = (%currservers,%server);
+ }
+ my %by_hostname;
+ foreach my $id (keys(%servers)) {
+ push(@{$by_hostname{$servers{$id}}},$id);
+ }
+ foreach my $hostname (sort(keys(%by_hostname))) {
+ if (@{$by_hostname{$hostname}} > 1) {
+ my $match = 0;
+ foreach my $id (@{$by_hostname{$hostname}}) {
+ if (&host_domain($id) eq $dom) {
+ $uniqservers{$id} = $hostname;
+ $match = 1;
+ }
+ }
+ unless ($match) {
+ $uniqservers{$by_hostname{$hostname}[0]} = $hostname;
+ }
+ } else {
+ $uniqservers{$by_hostname{$hostname}[0]} = $hostname;
+ }
+ }
+ return %uniqservers;
+}
+
# ---------------------- Find the homebase for a user from domain's lib servers
my %homecache;
@@ -1967,20 +2160,29 @@ sub getversion {
sub currentversion {
my $fname=shift;
- my ($result,$cached)=&is_cached_new('resversion',$fname);
- if (defined($cached)) { return $result; }
my $author=$fname;
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
my ($udom,$uname)=split(/\//,$author);
- my $home=homeserver($uname,$udom);
+ my $home=&homeserver($uname,$udom);
if ($home eq 'no_host') {
return -1;
}
- my $answer=reply("currentversion:$fname",$home);
+ my $answer=&reply("currentversion:$fname",$home);
if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
return -1;
}
- return &do_cache_new('resversion',$fname,$answer,600);
+ return $answer;
+}
+
+#
+# Return special version number of resource if set by override, empty otherwise
+#
+sub usedversion {
+ my $fname=shift;
+ unless ($fname) { $fname=$env{'request.uri'}; }
+ my ($urlversion)=($fname=~/\.(\d+)\.\w+$/);
+ if ($urlversion) { return $urlversion; }
+ return '';
}
# ----------------------------- Subscribe to a resource, return URL if possible
@@ -2176,6 +2378,8 @@ sub allowuploaded {
# path to file, source of file, instruction to parse file for objects,
# ref to hash for embedded objects,
# ref to hash for codebase of java objects.
+# reference to scalar to accommodate mime type determined
+# from File::MMagic if $parser = parse.
#
# output: url to file (if action was uploaddoc),
# ok if successful, or diagnostic message otherwise (if action was propagate or copy)
@@ -2202,7 +2406,8 @@ sub allowuploaded {
#
sub process_coursefile {
- my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase)=@_;
+ my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase,
+ $mimetype)=@_;
my $fetchresult;
my $home=&homeserver($docuname,$docudom);
if ($action eq 'propagate') {
@@ -2230,13 +2435,16 @@ sub process_coursefile {
close($fh);
if ($parser eq 'parse') {
my $mm = new File::MMagic;
- my $mime_type = $mm->checktype_filename($filepath.'/'.$fname);
- if ($mime_type eq 'text/html') {
+ my $type = $mm->checktype_filename($filepath.'/'.$fname);
+ if ($type eq 'text/html') {
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);
}
}
+ if (ref($mimetype)) {
+ $$mimetype = $type;
+ }
}
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
$home);
@@ -2369,26 +2577,27 @@ sub resizeImage {
# $thumbheight - height (pixels) of thumbnail to make for uploaded image
# $resizewidth - width (pixels) to which to resize uploaded image
# $resizeheight - height (pixels) to which to resize uploaded image
+# $mimetype - reference to scalar to accommodate mime type determined
+# from File::MMagic if $parser = parse.
#
# output: url of file in userspace, or error: <message>
# or /adm/notfound.html if failure to upload occurse
sub userfileupload {
my ($formname,$context,$subdir,$parser,$allfiles,$codebase,$destuname,
- $destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight)=@_;
+ $destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight,$mimetype)=@_;
if (!defined($subdir)) { $subdir='unknown'; }
my $fname=$env{'form.'.$formname.'.filename'};
$fname=&clean_filename($fname);
# See if there is anything left
unless ($fname) { return 'error: no uploaded file'; }
- chop($env{'form.'.$formname});
# Files uploaded to help request form, or uploaded to "create course" page are handled differently
if ((($formname eq 'screenshot') && ($subdir eq 'helprequests')) ||
(($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) ||
($context eq 'existingfile') || ($context eq 'canceloverwrite')) {
my $now = time;
my $filepath;
- if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) {
+ if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) {
$filepath = 'tmp/helprequests/'.$now;
} elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) {
$filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.
@@ -2452,12 +2661,12 @@ sub userfileupload {
return &finishuserfileupload($docuname,$docudom,
$formname,$fname,$parser,$allfiles,
$codebase,$thumbwidth,$thumbheight,
- $resizewidth,$resizeheight,$context);
+ $resizewidth,$resizeheight,$context,$mimetype);
} else {
$fname=$env{'form.folder'}.'/'.$fname;
return &process_coursefile('uploaddoc',$docuname,$docudom,
$fname,$formname,$parser,
- $allfiles,$codebase);
+ $allfiles,$codebase,$mimetype);
}
} elsif (defined($destuname)) {
my $docuname=$destuname;
@@ -2465,7 +2674,7 @@ sub userfileupload {
return &finishuserfileupload($docuname,$docudom,$formname,$fname,
$parser,$allfiles,$codebase,
$thumbwidth,$thumbheight,
- $resizewidth,$resizeheight,$context);
+ $resizewidth,$resizeheight,$context,$mimetype);
} else {
my $docuname=$env{'user.name'};
my $docudom=$env{'user.domain'};
@@ -2476,13 +2685,13 @@ sub userfileupload {
return &finishuserfileupload($docuname,$docudom,$formname,$fname,
$parser,$allfiles,$codebase,
$thumbwidth,$thumbheight,
- $resizewidth,$resizeheight,$context);
+ $resizewidth,$resizeheight,$context,$mimetype);
}
}
sub finishuserfileupload {
my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase,
- $thumbwidth,$thumbheight,$resizewidth,$resizeheight,$context) = @_;
+ $thumbwidth,$thumbheight,$resizewidth,$resizeheight,$context,$mimetype) = @_;
my $path=$docudom.'/'.$docuname.'/';
my $filepath=$perlvar{'lonDocRoot'};
@@ -2509,7 +2718,7 @@ sub finishuserfileupload {
return '/adm/notfound.html';
}
if ($context eq 'overwrite') {
- my $source = $perlvar{'lonDaemons'}.'/tmp/overwrites/'.$docudom.'/'.$docuname.'/'.$fname;
+ my $source = LONCAPA::tempdir().'/overwrites/'.$docudom.'/'.$docuname.'/'.$fname;
my $target = $filepath.'/'.$file;
if (-e $source) {
my @info = stat($source);
@@ -2540,8 +2749,8 @@ sub finishuserfileupload {
}
if ($parser eq 'parse') {
my $mm = new File::MMagic;
- my $mime_type = $mm->checktype_filename($filepath.'/'.$file);
- if ($mime_type eq 'text/html') {
+ my $type = $mm->checktype_filename($filepath.'/'.$file);
+ if ($type eq 'text/html') {
my $parse_result = &extract_embedded_items($filepath.'/'.$file,
$allfiles,$codebase);
unless ($parse_result eq 'ok') {
@@ -2549,6 +2758,9 @@ sub finishuserfileupload {
' for embedded media: '.$parse_result);
}
}
+ if (ref($mimetype)) {
+ $$mimetype = $type;
+ }
}
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
my $input = $filepath.'/'.$file;
@@ -3144,6 +3356,10 @@ sub get_my_roles {
if (!grep(/^cr$/,@{$roles})) {
next;
}
+ } elsif ($role =~ /^gr\//) {
+ if (!grep(/^gr$/,@{$roles})) {
+ next;
+ }
} else {
next;
}
@@ -3704,7 +3920,7 @@ sub tmpreset {
if ($domain eq 'public' && $stuname eq 'public') {
$stuname=$ENV{'REMOTE_ADDR'};
}
- my $path=$perlvar{'lonDaemons'}.'/tmp';
+ my $path=LONCAPA::tempdir();
my %hash;
if (tie(%hash,'GDBM_File',
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
@@ -3743,7 +3959,7 @@ sub tmpstore {
}
my $now=time;
my %hash;
- my $path=$perlvar{'lonDaemons'}.'/tmp';
+ my $path=LONCAPA::tempdir();
if (tie(%hash,'GDBM_File',
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
&GDBM_WRCREAT(),0640)) {
@@ -3789,7 +4005,7 @@ sub tmprestore {
$namespace=~s/\//\_/g;
$namespace=~s/\W//g;
my %hash;
- my $path=$perlvar{'lonDaemons'}.'/tmp';
+ my $path=LONCAPA::tempdir();
if (tie(%hash,'GDBM_File',
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
&GDBM_READER(),0640)) {
@@ -3926,6 +4142,8 @@ sub restore {
}
# ---------------------------------------------------------- Course Description
+#
+#
sub coursedescription {
my ($courseid,$args)=@_;
@@ -3955,7 +4173,8 @@ sub coursedescription {
return %returnhash;
}
- # get the data agin
+ # get the data again
+
if (!$args->{'one_time'}) {
$envhash{'course.'.$normalid.'.last_cache'}=time;
}
@@ -3963,6 +4182,10 @@ sub coursedescription {
if ($chome ne 'no_host') {
%returnhash=&dump('environment',$cdomain,$cnum);
if (!exists($returnhash{'con_lost'})) {
+ my $username = $env{'user.name'}; # Defult username
+ if(defined $args->{'user'}) {
+ $username = $args->{'user'};
+ }
$returnhash{'home'}= $chome;
$returnhash{'domain'} = $cdomain;
$returnhash{'num'} = $cnum;
@@ -3973,8 +4196,8 @@ sub coursedescription {
$envhash{'course.'.$normalid.'.'.$name}=$value;
}
$returnhash{'url'}=&clutter($returnhash{'url'});
- $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
- $env{'user.name'}.'_'.$cdomain.'_'.$cnum;
+ $returnhash{'fn'}=LONCAPA::tempdir() .
+ $username.'_'.$cdomain.'_'.$cnum;
$envhash{'course.'.$normalid.'.home'}=$chome;
$envhash{'course.'.$normalid.'.domain'}=$cdomain;
$envhash{'course.'.$normalid.'.num'}=$cnum;
@@ -4071,7 +4294,6 @@ sub rolesinit {
}
my %allroles=();
my %allgroups=();
- my $group_privs;
if ($rolesdump ne '') {
foreach my $entry (split(/&/,$rolesdump)) {
@@ -4088,6 +4310,7 @@ sub rolesinit {
}
} elsif ($role =~ m|^gr/|) {
($trole,$tend,$tstart) = split(/_/,$role);
+ next if ($tstart eq '-1');
($trole,$group_privs) = split(/\//,$trole);
$group_privs = &unescape($group_privs);
} else {
@@ -4240,7 +4463,7 @@ sub set_userprivs {
}
}
my $thesestr='';
- foreach my $priv (keys(%thesepriv)) {
+ foreach my $priv (sort(keys(%thesepriv))) {
$thesestr.=':'.$priv.'&'.$thesepriv{$priv};
}
$userroles->{'user.priv.'.$role} = $thesestr;
@@ -4249,7 +4472,7 @@ sub set_userprivs {
}
sub role_status {
- my ($rolekey,$then,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
+ my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
my @pwhere = ();
if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
(undef,undef,$$role,@pwhere)=split(/\./,$rolekey);
@@ -4258,7 +4481,7 @@ sub role_status {
$$trolecode=$$role.'.'.$$where;
($$tstart,$$tend)=split(/\./,$env{$rolekey});
$$tstatus='is';
- if ($$tstart && $$tstart>$then) {
+ if ($$tstart && $$tstart>$update) {
$$tstatus='future';
if ($$tstart<$now) {
if ($$tstart && $$tstart>$refresh) {
@@ -4283,32 +4506,9 @@ sub role_status {
$group_privs = &unescape($group_privs);
&group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);
my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1);
- if (keys(%course_roles) > 0) {
- my ($tnum) = ($trest =~ /^($match_courseid)/);
- if ($tdomain ne '' && $tnum ne '') {
- foreach my $key (keys(%course_roles)) {
- if ($key =~ /^\Q$tnum\E:\Q$tdomain\E:([^:]+):?([^:]*)/) {
- my $crsrole = $1;
- my $crssec = $2;
- if ($crsrole =~ /^cr/) {
- unless (grep(/^cr$/,@rolecodes)) {
- push(@rolecodes,'cr');
- }
- } else {
- unless(grep(/^\Q$crsrole\E$/,@rolecodes)) {
- push(@rolecodes,$crsrole);
- }
- }
- my $rolekey = $crsrole.'./'.$tdomain.'/'.$tnum;
- if ($crssec ne '') {
- $rolekey .= '/'.$crssec;
- }
- $rolekey .= './';
- $groups_roles{$rolekey} = \@rolecodes;
- }
- }
- }
- }
+ &get_groups_roles($tdomain,$trest,
+ \%course_roles,\@rolecodes,
+ \%groups_roles);
} else {
push(@rolecodes,$$role);
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
@@ -4322,7 +4522,7 @@ sub role_status {
}
}
if ($$tend) {
- if ($$tend<$then) {
+ if ($$tend<$update) {
$$tstatus='expired';
} elsif ($$tend<$now) {
$$tstatus='will_not';
@@ -4332,12 +4532,70 @@ sub role_status {
}
}
+sub get_groups_roles {
+ my ($cdom,$rest,$cdom_courseroles,$rolecodes,$groups_roles) = @_;
+ return unless((ref($cdom_courseroles) eq 'HASH') &&
+ (ref($rolecodes) eq 'ARRAY') &&
+ (ref($groups_roles) eq 'HASH'));
+ if (keys(%{$cdom_courseroles}) > 0) {
+ my ($cnum) = ($rest =~ /^($match_courseid)/);
+ if ($cdom ne '' && $cnum ne '') {
+ foreach my $key (keys(%{$cdom_courseroles})) {
+ if ($key =~ /^\Q$cnum\E:\Q$cdom\E:([^:]+):?([^:]*)/) {
+ my $crsrole = $1;
+ my $crssec = $2;
+ if ($crsrole =~ /^cr/) {
+ unless (grep(/^cr$/,@{$rolecodes})) {
+ push(@{$rolecodes},'cr');
+ }
+ } else {
+ unless(grep(/^\Q$crsrole\E$/,@{$rolecodes})) {
+ push(@{$rolecodes},$crsrole);
+ }
+ }
+ my $rolekey = "$crsrole./$cdom/$cnum";
+ if ($crssec ne '') {
+ $rolekey .= "/$crssec";
+ }
+ $rolekey .= './';
+ $groups_roles->{$rolekey} = $rolecodes;
+ }
+ }
+ }
+ }
+ return;
+}
+
+sub delete_env_groupprivs {
+ my ($where,$courseroles,$possroles) = @_;
+ return unless((ref($courseroles) eq 'HASH') && (ref($possroles) eq 'ARRAY'));
+ my ($dummy,$udom,$uname,$group) = split(/\//,$where);
+ unless (ref($courseroles->{$udom}) eq 'HASH') {
+ %{$courseroles->{$udom}} =
+ &get_my_roles('','','userroles',['active'],
+ $possroles,[$udom],1);
+ }
+ if (ref($courseroles->{$udom}) eq 'HASH') {
+ foreach my $item (keys(%{$courseroles->{$udom}})) {
+ my ($cnum,$cdom,$crsrole,$crssec) = split(/:/,$item);
+ my $area = '/'.$cdom.'/'.$cnum;
+ my $privkey = "user.priv.$crsrole.$area";
+ if ($crssec ne '') {
+ $privkey .= '/'.$crssec;
+ }
+ $privkey .= ".$area/$group";
+ &Apache::lonnet::delenv($privkey,undef,[$crsrole]);
+ }
+ }
+ return;
+}
+
sub check_adhoc_privs {
- my ($cdom,$cnum,$then,$refresh,$now,$checkrole,$caller) = @_;
+ my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;
my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
if ($env{$cckey}) {
my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
- &role_status($cckey,$then,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
+ &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {
&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
}
@@ -4428,15 +4686,18 @@ sub dump {
my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range:$extra",$uhome);
my @pairs=split(/\&/,$rep);
my %returnhash=();
- foreach my $item (@pairs) {
- my ($key,$value)=split(/=/,$item,2);
- $key = &unescape($key);
- next if ($key =~ /^error: 2 /);
- $returnhash{$key}=&thaw_unescape($value);
+ if (!($rep =~ /^error/ )) {
+ foreach my $item (@pairs) {
+ my ($key,$value)=split(/=/,$item,2);
+ $key = &unescape($key);
+ next if ($key =~ /^error: 2 /);
+ $returnhash{$key}=&thaw_unescape($value);
+ }
}
return %returnhash;
}
+
# --------------------------------------------------------- dumpstore interface
sub dumpstore {
@@ -4719,7 +4980,7 @@ sub tmpget {
return %returnhash;
}
-# ------------------------------------------------------------ tmpget interface
+# ------------------------------------------------------------ tmpdel interface
sub tmpdel {
my ($token,$server)=@_;
if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
@@ -5117,12 +5378,16 @@ sub is_advanced_user {
my ($udom,$uname) = @_;
if ($udom ne '' && $uname ne '') {
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
- return $env{'user.adv'};
+ if (wantarray) {
+ return ($env{'user.adv'},$env{'user.author'});
+ } else {
+ return $env{'user.adv'};
+ }
}
}
my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
my %allroles;
- my $is_adv;
+ my ($is_adv,$is_author);
foreach my $role (keys(%roleshash)) {
my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);
my $area = '/'.$tdomain.'/'.$trest;
@@ -5136,6 +5401,9 @@ sub is_advanced_user {
} elsif ($trole ne 'gr') {
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
}
+ if ($trole eq 'au') {
+ $is_author = 1;
+ }
}
}
foreach my $role (keys(%allroles)) {
@@ -5150,6 +5418,9 @@ sub is_advanced_user {
}
}
}
+ if (wantarray) {
+ return ($is_adv,$is_author);
+ }
return $is_adv;
}
@@ -5635,7 +5906,7 @@ sub allowed {
my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
=~/\Q$rolecode\E/) {
- if ($priv ne 'pch') {
+ if (($priv ne 'pch') && ($priv ne 'plc')) {
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
$env{'request.course.id'});
@@ -5645,7 +5916,7 @@ sub allowed {
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
=~/\Q$unamedom\E/) {
- if ($priv ne 'pch') {
+ if (($priv ne 'pch') && ($priv ne 'plc')) {
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
$env{'request.course.id'});
@@ -5659,7 +5930,7 @@ sub allowed {
if ($thisallowed=~/R/) {
my $rolecode=(split(/\./,$env{'request.role'}))[0];
if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
- if ($priv ne 'pch') {
+ if (($priv ne 'pch') && ($priv ne 'plc')) {
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
}
@@ -5886,7 +6157,7 @@ sub fetch_enrollment_query {
$$replyref{$key} = $value;
}
} else {
- my $pathname = $perlvar{'lonDaemons'}.'/tmp';
+ my $pathname = LONCAPA::tempdir();
foreach my $line (@responses) {
my ($key,$value) = split(/=/,$line);
$$replyref{$key} = $value;
@@ -5916,7 +6187,7 @@ sub fetch_enrollment_query {
sub get_query_reply {
my $queryid=shift;
- my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;
+ my $replyfile=LONCAPA::tempdir().$queryid;
my $reply='';
for (1..100) {
sleep 2;
@@ -6012,9 +6283,9 @@ sub auto_get_sections {
}
sub auto_new_course {
- my ($cnum,$cdom,$inst_course_id,$owner) = @_;
+ my ($cnum,$cdom,$inst_course_id,$owner,$coowners) = @_;
my $homeserver = &homeserver($cnum,$cdom);
- my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
+ my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.&escape($owner).':'.$cdom.':'.&escape($coowners),$homeserver));
return $response;
}
@@ -7231,8 +7502,8 @@ sub store_userdata {
$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
}
$namevalue=~s/\&$//;
- $result = &reply("store:$env{'user.domain'}:$env{'user.name'}:".
- "$namespace:$datakey:$namevalue",$uhome);
+ $result = &reply("store:$udom:$uname:$namespace:$datakey:".
+ $namevalue,$uhome);
}
} else {
$result = 'error: data to store was not a hash reference';
@@ -7285,7 +7556,7 @@ sub diskusage {
}
sub is_locked {
- my ($file_name, $domain, $user) = @_;
+ my ($file_name, $domain, $user, $which) = @_;
my @check;
my $is_locked;
push (@check,$file_name);
@@ -7297,9 +7568,13 @@ sub is_locked {
if (ref($locked{$file_name}) eq 'ARRAY') {
$is_locked = 'false';
foreach my $entry (@{$locked{$file_name}}) {
- if (ref($entry) eq 'ARRAY') {
+ if (ref($entry) eq 'ARRAY') {
$is_locked = 'true';
- last;
+ if (ref($which) eq 'ARRAY') {
+ push(@{$which},$entry);
+ } else {
+ last;
+ }
}
}
} else {
@@ -7349,7 +7624,7 @@ sub save_selected_files {
sub clear_selected_files {
my ($user) = @_;
my $filename = $user."savedfiles";
- open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
+ open (OUT, '>'.LONCAPA::tempdir().$filename);
print (OUT undef);
close (OUT);
return ("ok");
@@ -7359,7 +7634,7 @@ sub files_in_path {
my ($user, $path) = @_;
my $filename = $user."savedfiles";
my %return_files;
- open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
+ open (IN, '<'.LONCAPA::tempdir().$filename);
while (my $line_in = <IN>) {
chomp ($line_in);
my @paths_and_file = split (m!/!, $line_in);
@@ -7381,7 +7656,7 @@ sub files_not_in_path {
my $filename = $user."savedfiles";
my @return_files;
my $path_part;
- open(IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
+ open(IN, '<'.LONCAPA::.$filename);
while (my $line = <IN>) {
#ok, I know it's clunky, but I want it to work
my @paths_and_file = split(m|/|, $line);
@@ -8456,7 +8731,7 @@ sub metadata {
if (($uri eq '') ||
(($uri =~ m|^/*adm/|) &&
($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
- ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^\*uploaded\/.+\.sequence$/) ) {
+ ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
return undef;
}
if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/})
@@ -8502,7 +8777,8 @@ sub metadata {
&Apache::lonnet::ssi_body($which,
('grade_target' => 'meta'));
$cachetime = 1; # only want this cached in the child not long term
- } elsif ($uri !~ m -^(editupload)/-) {
+ } elsif (($uri !~ m -^(editupload)/-) &&
+ ($uri !~ m{^/*uploaded/$match_domain/$match_courseid/docs/})) {
my $file=&filelocation('',&clutter($filename));
#push(@{$metaentry{$uri.'.file'}},$file);
$metastring=&getfile($file);
@@ -8901,8 +9177,9 @@ sub symbverify {
$thisurl =~ s/\?.+$//;
}
my $ids=$bighash{'ids_'.&clutter($thisurl)};
- unless ($ids) {
- $ids=$bighash{'ids_/'.$thisurl};
+ unless ($ids) {
+ my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;
+ $ids=$bighash{$idkey};
}
if ($ids) {
# ------------------------------------------------------------------- Has ID(s)
@@ -8915,7 +9192,8 @@ sub symbverify {
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
eq $symb) {
if (($env{'request.role.adv'}) ||
- $bighash{'encrypted_'.$id} eq $env{'request.enc'}) {
+ ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
+ ($thisurl eq '/adm/navmaps')) {
$okay=1;
}
}
@@ -9672,7 +9950,7 @@ sub filelocation {
my @ids=¤t_machine_ids();
foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
if ($is_me) {
- $location=&propath($udom,$uname).'/userfiles/'.$filename;
+ $location=propath($udom,$uname).'/userfiles/'.$filename;
} else {
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
$udom.'/'.$uname.'/'.$filename;
@@ -9994,13 +10272,19 @@ sub get_dns {
my $loaded;
my %name_to_host;
my %internetdom;
+ my %LC_dns_serv;
sub parse_hosts_tab {
my ($file) = @_;
foreach my $configline (@$file) {
next if ($configline =~ /^(\#|\s*$ )/x);
- next if ($configline =~ /^\^/);
- chomp($configline);
+ chomp($configline);
+ if ($configline =~ /^\^/) {
+ if ($configline =~ /^\^([\w.\-]+)/) {
+ $LC_dns_serv{$1} = 1;
+ }
+ next;
+ }
my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);
$name=~s/\s//g;
if ($id && $domain && $role && $name) {
@@ -10136,6 +10420,14 @@ sub get_dns {
my ($lonid) = @_;
return $internetdom{$lonid};
}
+
+ sub is_LC_dns {
+ &load_hosts_tab() if (!$loaded);
+
+ my ($hostname) = @_;
+ return exists($LC_dns_serv{$hostname});
+ }
+
}
{
@@ -10413,7 +10705,7 @@ BEGIN {
# ------------- set up temporary directory
{
- $tmpdir = $perlvar{'lonDaemons'}.'/tmp/';
+ $tmpdir = LONCAPA::tempdir();
}
@@ -10907,11 +11199,32 @@ revokecustomrole($udom,$uname,$url,$role
=item *
-coursedescription($courseid) : returns a hash of information about the
+coursedescription($courseid,$options) : returns a hash of information about the
specified course id, including all environment settings for the
course, the description of the course will be in the hash under the
key 'description'
+$options is an optional parameter that if supplied is a hash reference that controls
+what how this function works. It has the following key/values:
+
+=over 4
+
+=item freshen_cache
+
+If defined, and the environment cache for the course is valid, it is
+returned in the returned hash.
+
+=item one_time
+
+If defined, the last cache time is set to _now_
+
+=item user
+
+If defined, the supplied username is used instead of the current user.
+
+
+=back
+
=item *
resdata($name,$domain,$type,@which) : request for current parameter
@@ -11304,11 +11617,12 @@ splitting on '&', supports elements that
=head2 Logging Routines
-=over 4
These routines allow one to make log messages in the lonnet.log and
lonnet.perm logfiles.
+=over 4
+
=item *
logtouch() : make sure the logfile, lonnet.log, exists
@@ -11324,6 +11638,7 @@ logperm() : append a permanent message t
file never gets deleted by any automated portion of the system, only
messages of critical importance should go in here.
+
=back
=head2 General File Helper Routines
@@ -11438,6 +11753,8 @@ userspace, probably shouldn't be called
resizeheight: height to be used to resize image using resizeImage from ImageMagick
context: if 'overwrite', will move the uploaded file from its temporary location to
userfiles to facilitate overwriting a previously uploaded file with same name.
+ mimetype: reference to scalar to accommodate mime type determined
+ from File::MMagic if $parser = parse.
returns either the url of the uploaded file (/uploaded/....) if successful
and /adm/notfound.html if unsuccessful (or an error message if context