--- loncom/lonnet/perl/lonnet.pm 2008/08/27 02:29:31 1.965
+++ loncom/lonnet/perl/lonnet.pm 2010/05/03 16:41:57 1.1061
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.965 2008/08/27 02:29:31 raeburn Exp $
+# $Id: lonnet.pm,v 1.1061 2010/05/03 16:41:57 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -27,14 +27,56 @@
#
###
+=pod
+
+=head1 NAME
+
+Apache::lonnet.pm
+
+=head1 SYNOPSIS
+
+This file is an interface to the lonc processes of
+the LON-CAPA network as well as set of elaborated functions for handling information
+necessary for navigating through a given cluster of LON-CAPA machines within a
+domain. There are over 40 specialized functions in this module which handle the
+reading and transmission of metadata, user information (ids, names, environments, roles,
+logs), file information (storage, reading, directories, extensions, replication, embedded
+styles and descriptors), educational resources (course descriptions, section names and
+numbers), url hashing (to assign roles on a url basis), and translating abbreviated symbols to
+and from more descriptive phrases or explanations.
+
+This is part of the LearningOnline Network with CAPA project
+described at http://www.lon-capa.org.
+
+=head1 Package Variables
+
+These are largely undocumented, so if you decipher one please note it here.
+
+=over 4
+
+=item $processmarker
+
+Contains the time this process was started and this servers host id.
+
+=item $dumpcount
+
+Counts the number of times a message log flush has been attempted (regardless
+of success) by this process. Used as part of the filename when messages are
+delayed.
+
+=back
+
+=cut
+
package Apache::lonnet;
use strict;
use LWP::UserAgent();
use HTTP::Date;
-# use Date::Parse;
+use Image::Magick;
+
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
- $_64bit %env);
+ $_64bit %env %protocol);
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
%userrolehash, $processmarker, $dumpcount, %coursedombuf,
@@ -50,6 +92,7 @@ use Time::HiRes qw( gettimeofday tv_inte
use Cache::Memcached;
use Digest::MD5;
use Math::Random;
+use File::MMagic;
use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;
@@ -61,28 +104,6 @@ require Exporter;
our @ISA = qw (Exporter);
our @EXPORT = qw(%env);
-=pod
-
-=head1 Package Variables
-
-These are largely undocumented, so if you decipher one please note it here.
-
-=over 4
-
-=item $processmarker
-
-Contains the time this process was started and this servers host id.
-
-=item $dumpcount
-
-Counts the number of times a message log flush has been attempted (regardless
-of success) by this process. Used as part of the filename when messages are
-delayed.
-
-=back
-
-=cut
-
# --------------------------------------------------------------------- Logging
{
@@ -127,7 +148,8 @@ sub logthis {
my $now=time;
my $local=localtime($now);
if (open(my $fh,">>$execdir/logs/lonnet.log")) {
- print $fh "$local ($$): $message\n";
+ my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.
+ print $fh $logstring;
close($fh);
}
return 1;
@@ -158,6 +180,47 @@ sub create_connection {
return 0;
}
+sub get_server_timezone {
+ my ($cnum,$cdom) = @_;
+ my $home=&homeserver($cnum,$cdom);
+ if ($home ne 'no_host') {
+ my $cachetime = 24*3600;
+ my ($timezone,$cached)=&is_cached_new('servertimezone',$home);
+ if (defined($cached)) {
+ return $timezone;
+ } else {
+ my $timezone = &reply('servertimezone',$home);
+ return &do_cache_new('servertimezone',$home,$timezone,$cachetime);
+ }
+ }
+}
+
+sub get_server_loncaparev {
+ my ($dom,$lonhost) = @_;
+ if (defined($lonhost)) {
+ if (!defined(&hostname($lonhost))) {
+ undef($lonhost);
+ }
+ }
+ if (!defined($lonhost)) {
+ if (defined(&domain($dom,'primary'))) {
+ $lonhost=&domain($dom,'primary');
+ if ($lonhost eq 'no_host') {
+ undef($lonhost);
+ }
+ }
+ }
+ if (defined($lonhost)) {
+ my $cachetime = 24*3600;
+ my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost);
+ if (defined($cached)) {
+ return $loncaparev;
+ } else {
+ my $loncaparev = &reply('serverloncaparev',$lonhost);
+ return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime);
+ }
+ }
+}
# -------------------------------------------------- Non-critical communication
sub subreply {
@@ -489,7 +552,7 @@ sub appenv {
# ----------------------------------------------------- Delete from Environment
sub delenv {
- my $delthis=shift;
+ my ($delthis,$regexp) = @_;
if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
&logthis("<font color=\"blue\">WARNING: ".
"Attempt to delete from environment ".$delthis);
@@ -502,10 +565,17 @@ sub delenv {
tie(my %disk_env,'GDBM_File',$env{'user.environment'},
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
foreach my $key (keys(%disk_env)) {
- if ($key=~/^$delthis/) {
- delete($env{$key});
- delete($disk_env{$key});
- }
+ if ($regexp) {
+ if ($key=~/^$delthis/) {
+ delete($env{$key});
+ delete($disk_env{$key});
+ }
+ } else {
+ if ($key=~/^\Q$delthis\E/) {
+ delete($env{$key});
+ delete($disk_env{$key});
+ }
+ }
}
untie(%disk_env);
}
@@ -595,30 +665,6 @@ sub userload {
return $userloadpercent;
}
-# ------------------------------------------ Fight off request when overloaded
-
-sub overloaderror {
- my ($r,$checkserver)=@_;
- unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }
- my $loadavg;
- if ($checkserver eq $perlvar{'lonHostID'}) {
- open(my $loadfile,'/proc/loadavg');
- $loadavg=<$loadfile>;
- $loadavg =~ s/\s.*//g;
- $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};
- close($loadfile);
- } else {
- $loadavg=&reply('load',$checkserver);
- }
- my $overload=$loadavg-100;
- if ($overload>0) {
- $r->err_headers_out->{'Retry-After'}=$overload;
- $r->log_error('Overload of '.$overload.' on '.$checkserver);
- return 413;
- }
- return '';
-}
-
# ------------------------------ Find server with least workload from spare.tab
sub spareserver {
@@ -643,7 +689,16 @@ sub spareserver {
}
if (!$want_server_name) {
- $spare_server="http://".&hostname($spare_server);
+ my $protocol = 'http';
+ if ($protocol{$spare_server} eq 'https') {
+ $protocol = $protocol{$spare_server};
+ }
+ if (defined($spare_server)) {
+ my $hostname = &hostname($spare_server);
+ if (defined($hostname)) {
+ $spare_server = $protocol.'://'.$hostname;
+ }
+ }
}
return $spare_server;
}
@@ -704,7 +759,8 @@ sub changepass {
my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
$currentpass = &escape($currentpass);
$newpass = &escape($newpass);
- my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context",
+ my $lonhost = $perlvar{'lonHostID'};
+ my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context:$lonhost",
$server);
if (! $answer) {
&logthis("No reply on password change request to $server ".
@@ -729,6 +785,9 @@ sub changepass {
} elsif ($answer =~ "^refused") {
&logthis("$server refused to change $uname in $udom password because ".
"it was sent an unencrypted request to change the password.");
+ } elsif ($answer =~ "invalid_client") {
+ &logthis("$server refused to change $uname in $udom password because ".
+ "it was a reset by e-mail originating from an invalid server.");
}
return $answer;
}
@@ -878,7 +937,21 @@ sub idput {
}
}
-# ------------------------------------------- get items from domain db files
+# ------------------------------dump from db file owned by domainconfig user
+sub dump_dom {
+ my ($namespace,$udom,$regexp,$range)=@_;
+ if (!$udom) {
+ $udom=$env{'user.domain'};
+ }
+ my %returnhash;
+ if ($udom) {
+ my $uname = &get_domainconfiguser($udom);
+ %returnhash = &dump($namespace,$udom,$uname,$regexp,$range);
+ }
+ return %returnhash;
+}
+
+# ------------------------------------------ get items from domain db files
sub get_dom {
my ($namespace,$storearr,$udom,$uhome)=@_;
@@ -952,30 +1025,71 @@ sub put_dom {
}
}
+# --------------------- newput for items in db file owned by domainconfig user
+sub newput_dom {
+ my ($namespace,$storehash,$udom) = @_;
+ my $result;
+ if (!$udom) {
+ $udom=$env{'user.domain'};
+ }
+ if ($udom) {
+ my $uname = &get_domainconfiguser($udom);
+ $result = &newput($namespace,$storehash,$udom,$uname);
+ }
+ return $result;
+}
+
+# --------------------- delete for items in db file owned by domainconfig user
+sub del_dom {
+ my ($namespace,$storearr,$udom)=@_;
+ if (ref($storearr) eq 'ARRAY') {
+ if (!$udom) {
+ $udom=$env{'user.domain'};
+ }
+ if ($udom) {
+ my $uname = &get_domainconfiguser($udom);
+ return &del($namespace,$storearr,$udom,$uname);
+ }
+ }
+}
+
+# ----------------------------------construct domainconfig user for a domain
+sub get_domainconfiguser {
+ my ($udom) = @_;
+ return $udom.'-domainconfig';
+}
+
sub retrieve_inst_usertypes {
my ($udom) = @_;
my (%returnhash,@order);
- if (defined(&domain($udom,'primary'))) {
- my $uhome=&domain($udom,'primary');
- my $rep=&reply("inst_usertypes:$udom",$uhome);
- if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
- &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");
- return (\%returnhash,\@order);
- }
- my ($hashitems,$orderitems) = split(/:/,$rep);
- my @pairs=split(/\&/,$hashitems);
- foreach my $item (@pairs) {
- my ($key,$value)=split(/=/,$item,2);
- $key = &unescape($key);
- next if ($key =~ /^error: 2 /);
- $returnhash{$key}=&thaw_unescape($value);
- }
- my @esc_order = split(/\&/,$orderitems);
- foreach my $item (@esc_order) {
- push(@order,&unescape($item));
- }
+ my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
+ if ((ref($domdefs{'inststatustypes'}) eq 'HASH') &&
+ (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
+ %returnhash = %{$domdefs{'inststatustypes'}};
+ @order = @{$domdefs{'inststatusorder'}};
} else {
- &logthis("get_dom failed - no primary domain server for $udom");
+ if (defined(&domain($udom,'primary'))) {
+ my $uhome=&domain($udom,'primary');
+ my $rep=&reply("inst_usertypes:$udom",$uhome);
+ if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
+ &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");
+ return (\%returnhash,\@order);
+ }
+ my ($hashitems,$orderitems) = split(/:/,$rep);
+ my @pairs=split(/\&/,$hashitems);
+ foreach my $item (@pairs) {
+ my ($key,$value)=split(/=/,$item,2);
+ $key = &unescape($key);
+ next if ($key =~ /^error: 2 /);
+ $returnhash{$key}=&thaw_unescape($value);
+ }
+ my @esc_order = split(/\&/,$orderitems);
+ foreach my $item (@esc_order) {
+ push(@order,&unescape($item));
+ }
+ } else {
+ &logthis("get_dom failed - no primary domain server for $udom");
+ }
}
return (\%returnhash,\@order);
}
@@ -1199,12 +1313,11 @@ sub inst_userrules {
return (\%ruleshash,\@ruleorder);
}
-# ------------------------- Get Authentication and Language Defaults for Domain
+# ------------- Get Authentication, Language and User Tools Defaults for Domain
sub get_domain_defaults {
my ($domain) = @_;
my $cachetime = 60*60*24;
- my ($defauthtype,$defautharg,$deflang);
my ($result,$cached)=&is_cached_new('domdefaults',$domain);
if (defined($cached)) {
if (ref($result) eq 'HASH') {
@@ -1213,16 +1326,48 @@ sub get_domain_defaults {
}
my %domdefaults;
my %domconfig =
- &Apache::lonnet::get_dom('configuration',['defaults'],$domain);
+ &Apache::lonnet::get_dom('configuration',['defaults','quotas',
+ 'requestcourses','inststatus',
+ 'coursedefaults'],$domain);
if (ref($domconfig{'defaults'}) eq 'HASH') {
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
$domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
+ $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
+ $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
} else {
$domdefaults{'lang_def'} = &domain($domain,'lang_def');
$domdefaults{'auth_def'} = &domain($domain,'auth_def');
$domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def');
}
+ if (ref($domconfig{'quotas'}) eq 'HASH') {
+ if (ref($domconfig{'quotas'}{'defaultquota'}) eq 'HASH') {
+ $domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'};
+ } else {
+ $domdefaults{'defaultquota'} = $domconfig{'quotas'};
+ }
+ my @usertools = ('aboutme','blog','portfolio');
+ foreach my $item (@usertools) {
+ if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
+ $domdefaults{$item} = $domconfig{'quotas'}{$item};
+ }
+ }
+ }
+ if (ref($domconfig{'requestcourses'}) eq 'HASH') {
+ foreach my $item ('official','unofficial','community') {
+ $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
+ }
+ }
+ if (ref($domconfig{'inststatus'}) eq 'HASH') {
+ foreach my $item ('inststatustypes','inststatusorder') {
+ $domdefaults{$item} = $domconfig{'inststatus'}{$item};
+ }
+ }
+ if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
+ foreach my $item ('canuse_pdfforms') {
+ $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};
+ }
+ }
&Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
$cachetime);
return %domdefaults;
@@ -1547,13 +1692,23 @@ sub purge_remembered {
sub userenvironment {
my ($udom,$unam,@what)=@_;
+ my $items;
+ foreach my $item (@what) {
+ $items.=&escape($item).'&';
+ }
+ $items=~s/\&$//;
my %returnhash=();
- my @answer=split(/\&/,
- &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),
- &homeserver($unam,$udom)));
- my $i;
- for ($i=0;$i<=$#what;$i++) {
- $returnhash{$what[$i]}=&unescape($answer[$i]);
+ my $uhome = &homeserver($unam,$udom);
+ unless ($uhome eq 'no_host') {
+ my @answer=split(/\&/,
+ &reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome));
+ if ($#answer==0 && $answer[0] =~ /^(con_lost|error:|no_such_host)/i) {
+ return %returnhash;
+ }
+ my $i;
+ for ($i=0;$i<=$#what;$i++) {
+ $returnhash{$what[$i]}=&unescape($answer[$i]);
+ }
}
return %returnhash;
}
@@ -1746,9 +1901,11 @@ sub ssi_body {
}
my $output='';
my $response;
- if ($filelink=~/^http\:/) {
+ if ($filelink=~/^https?\:/) {
($output,$response)=&externalssi($filelink);
} else {
+ $filelink .= $filelink=~/\?/ ? '&' : '?';
+ $filelink .= 'inhibitmenu=yes';
($output,$response)=&ssi($filelink,%form);
}
$output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
@@ -1792,7 +1949,7 @@ sub ssi {
&Apache::lonenc::check_encrypt(\$fn);
if (%form) {
$request=new HTTP::Request('POST',&absolute_url().$fn);
- $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
+ $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form)));
} else {
$request=new HTTP::Request('GET',&absolute_url().$fn);
}
@@ -1890,9 +2047,13 @@ sub process_coursefile {
print $fh $env{'form.'.$source};
close($fh);
if ($parser eq 'parse') {
- 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);
+ my $mm = new File::MMagic;
+ my $mime_type = $mm->checktype_filename($filepath.'/'.$fname);
+ if ($mime_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);
+ }
}
}
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
@@ -1969,6 +2130,43 @@ sub clean_filename {
$fname=~s/\.(\d+)(?=\.)/_$1/g;
return $fname;
}
+# This Function checks if an Image's dimensions exceed either $resizewidth (width)
+# or $resizeheight (height) - both pixels. If so, the image is scaled to produce an
+# image with the same aspect ratio as the original, but with dimensions which do
+# not exceed $resizewidth and $resizeheight.
+
+sub resizeImage {
+ my ($img_path,$resizewidth,$resizeheight) = @_;
+ my $ima = Image::Magick->new;
+ my $resized;
+ if (-e $img_path) {
+ $ima->Read($img_path);
+ if (($resizewidth =~ /^\d+$/) && ($resizeheight > 0)) {
+ my $width = $ima->Get('width');
+ my $height = $ima->Get('height');
+ if ($width > $resizewidth) {
+ my $factor = $width/$resizewidth;
+ my $newheight = $height/$factor;
+ $ima->Scale(width=>$resizewidth,height=>$newheight);
+ $resized = 1;
+ }
+ }
+ if (($resizeheight =~ /^\d+$/) && ($resizeheight > 0)) {
+ my $width = $ima->Get('width');
+ my $height = $ima->Get('height');
+ if ($height > $resizeheight) {
+ my $factor = $height/$resizeheight;
+ my $newwidth = $width/$factor;
+ $ima->Scale(width=>$newwidth,height=>$resizeheight);
+ $resized = 1;
+ }
+ }
+ if ($resized) {
+ $ima->Write($img_path);
+ }
+ }
+ return;
+}
# --------------- Take an uploaded file and put it into the userfiles directory
# input: $formname - the contents of the file are in $env{"form.$formname"}
@@ -1983,14 +2181,15 @@ sub clean_filename {
# $dsetudom - domain for permanaent storage of uploaded file
# $thumbwidth - width (pixels) of thumbnail to make for uploaded image
# $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
#
# output: url of file in userspace, or error: <message>
# or /adm/notfound.html if failure to upload occurse
-
sub userfileupload {
my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,
- $destudom,$thumbwidth,$thumbheight)=@_;
+ $destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight)=@_;
if (!defined($subdir)) { $subdir='unknown'; }
my $fname=$env{'form.'.$formname.'.filename'};
$fname=&clean_filename($fname);
@@ -2028,16 +2227,20 @@ sub userfileupload {
close($fh);
return $fullpath.'/'.$fname;
}
-
+ if ($subdir eq 'scantron') {
+ $fname = 'scantron_orig_'.$fname;
+ } else {
# Create the directory if not present
- $fname="$subdir/$fname";
+ $fname="$subdir/$fname";
+ }
if ($coursedoc) {
my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
return &finishuserfileupload($docuname,$docudom,
$formname,$fname,$parser,$allfiles,
- $codebase,$thumbwidth,$thumbheight);
+ $codebase,$thumbwidth,$thumbheight,
+ $resizewidth,$resizeheight);
} else {
$fname=$env{'form.folder'}.'/'.$fname;
return &process_coursefile('uploaddoc',$docuname,$docudom,
@@ -2049,7 +2252,8 @@ sub userfileupload {
my $docudom=$destudom;
return &finishuserfileupload($docuname,$docudom,$formname,$fname,
$parser,$allfiles,$codebase,
- $thumbwidth,$thumbheight);
+ $thumbwidth,$thumbheight,
+ $resizewidth,$resizeheight);
} else {
my $docuname=$env{'user.name'};
@@ -2060,15 +2264,17 @@ sub userfileupload {
}
return &finishuserfileupload($docuname,$docudom,$formname,$fname,
$parser,$allfiles,$codebase,
- $thumbwidth,$thumbheight);
+ $thumbwidth,$thumbheight,
+ $resizewidth,$resizeheight);
}
}
sub finishuserfileupload {
my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase,
- $thumbwidth,$thumbheight) = @_;
+ $thumbwidth,$thumbheight,$resizewidth,$resizeheight) = @_;
my $path=$docudom.'/'.$docuname.'/';
my $filepath=$perlvar{'lonDocRoot'};
+
my ($fnamepath,$file,$fetchthumb);
$file=$fname;
if ($fname=~m|/|) {
@@ -2083,6 +2289,7 @@ sub finishuserfileupload {
mkdir($filepath,0777);
}
}
+
# Save the file
{
if (!open(FH,'>'.$filepath.'/'.$file)) {
@@ -2096,13 +2303,24 @@ sub finishuserfileupload {
return '/adm/notfound.html';
}
close(FH);
+ if ($resizewidth && $resizeheight) {
+ my $mm = new File::MMagic;
+ my $mime_type = $mm->checktype_filename($filepath.'/'.$file);
+ if ($mime_type =~ m{^image/}) {
+ &resizeImage($filepath.'/'.$file,$resizewidth,$resizeheight);
+ }
+ }
}
if ($parser eq 'parse') {
- my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles,
- $codebase);
- unless ($parse_result eq 'ok') {
- &logthis('Failed to parse '.$filepath.$file.
- ' for embedded media: '.$parse_result);
+ my $mm = new File::MMagic;
+ my $mime_type = $mm->checktype_filename($filepath.'/'.$file);
+ if ($mime_type eq 'text/html') {
+ my $parse_result = &extract_embedded_items($filepath.'/'.$file,
+ $allfiles,$codebase);
+ unless ($parse_result eq 'ok') {
+ &logthis('Failed to parse '.$filepath.$file.
+ ' for embedded media: '.$parse_result);
+ }
}
}
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
@@ -2117,7 +2335,7 @@ sub finishuserfileupload {
# Notify homeserver to grep it
#
- my $docuhome=&homeserver($docuname,$docudom);
+ my $docuhome=&homeserver($docuname,$docudom);
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
if ($fetchresult eq 'ok') {
if ($fetchthumb) {
@@ -2249,21 +2467,21 @@ sub add_filetype {
}
sub removeuploadedurl {
- my ($url)=@_;
- my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
+ my ($url)=@_;
+ my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
return &removeuserfile($uname,$udom,$fname);
}
sub removeuserfile {
my ($docuname,$docudom,$fname)=@_;
- my $home=&homeserver($docuname,$docudom);
+ my $home=&homeserver($docuname,$docudom);
my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
- if ($result eq 'ok') {
+ if ($result eq 'ok') {
if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
my $metafile = $fname.'.meta';
my $metaresult = &removeuserfile($docuname,$docudom,$metafile);
my $url = "/uploaded/$docudom/$docuname/$fname";
- my ($file,$group) = (&parse_portfolio_url($url))[3,4];
+ my ($file,$group) = (&parse_portfolio_url($url))[3,4];
my $sqlresult =
&update_portfolio_table($docuname,$docudom,$file,
'portfolio_metadata',$group,
@@ -2406,7 +2624,7 @@ sub flushcourselogs {
# Reverse lookup of domain roles (dc, ad, li, sc, au)
#
my %domrolebuffer = ();
- foreach my $entry (keys %domainrolehash) {
+ foreach my $entry (keys(%domainrolehash)) {
my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry);
if ($domrolebuffer{$rudom}) {
$domrolebuffer{$rudom}.='&'.&escape($entry).
@@ -2466,7 +2684,12 @@ sub courseacclog {
# FIXME: Probably ought to escape things....
foreach my $key (keys(%env)) {
if ($key=~/^form\.(.*)/) {
- $what.=':'.$1.'='.$env{$key};
+ my $formitem = $1;
+ if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) {
+ $what.=':'.$formitem.'='.$env{$key};
+ } elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {
+ $what.=':'.$formitem.'='.$env{$key};
+ }
}
}
} elsif ($fnsymb =~ m:^/adm/searchcat:) {
@@ -2506,7 +2729,7 @@ sub userrolelog {
if (($trole=~/^ca/) || ($trole=~/^aa/) ||
($trole=~/^in/) || ($trole=~/^cc/) ||
($trole=~/^ep/) || ($trole=~/^cr/) ||
- ($trole=~/^ta/)) {
+ ($trole=~/^ta/) || ($trole=~/^co/)) {
my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
$userrolehash
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
@@ -2515,7 +2738,8 @@ sub userrolelog {
if (($env{'request.role'} =~ /dc\./) &&
(($trole=~/^au/) || ($trole=~/^in/) ||
($trole=~/^cc/) || ($trole=~/^ep/) ||
- ($trole=~/^cr/) || ($trole=~/^ta/))) {
+ ($trole=~/^cr/) || ($trole=~/^ta/) ||
+ ($trole=~/^co/))) {
$userrolehash
{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
=$tend.':'.$tstart;
@@ -2536,7 +2760,8 @@ sub courserolelog {
if (($trole eq 'cc') || ($trole eq 'in') ||
($trole eq 'ep') || ($trole eq 'ad') ||
($trole eq 'ta') || ($trole eq 'st') ||
- ($trole=~/^cr/) || ($trole eq 'gr')) {
+ ($trole=~/^cr/) || ($trole eq 'gr') ||
+ ($trole eq 'co')) {
if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
my $cdom = $1;
my $cnum = $2;
@@ -2556,6 +2781,9 @@ sub courserolelog {
$storehash{'section'} = $sec;
}
&instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);
+ if (($trole ne 'st') || ($sec ne '')) {
+ &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);
+ }
}
}
return;
@@ -2565,6 +2793,7 @@ sub get_course_adv_roles {
my ($cid,$codes) = @_;
$cid=$env{'request.course.id'} unless (defined($cid));
my %coursehash=&coursedescription($cid);
+ my $crstype = &Apache::loncommon::course_type($cid);
my %nothide=();
foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
if ($user !~ /:/) {
@@ -2577,15 +2806,29 @@ sub get_course_adv_roles {
my %dumphash=
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
my $now=time;
- foreach my $entry (keys %dumphash) {
+ my %privileged;
+ foreach my $entry (keys(%dumphash)) {
my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
if (($tstart) && ($tstart<0)) { next; }
if (($tend) && ($tend<$now)) { next; }
if (($tstart) && ($now<$tstart)) { next; }
my ($role,$username,$domain,$section)=split(/\:/,$entry);
if ($username eq '' || $domain eq '') { next; }
- if ((&privileged($username,$domain)) &&
- (!$nothide{$username.':'.$domain})) { next; }
+ unless (ref($privileged{$domain}) eq 'HASH') {
+ my %dompersonnel =
+ &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
+ $privileged{$domain} = {};
+ foreach my $server (keys(%dompersonnel)) {
+ if (ref($dompersonnel{$server}) eq 'HASH') {
+ foreach my $user (keys(%{$dompersonnel{$server}})) {
+ my ($trole,$uname,$udom) = split(/:/,$user);
+ $privileged{$udom}{$uname} = 1;
+ }
+ }
+ }
+ }
+ if ((exists($privileged{$domain}{$username})) &&
+ (!$nothide{$username.':'.$domain})) { next; }
if ($role eq 'cr') { next; }
if ($codes) {
if ($section) { $role .= ':'.$section; }
@@ -2595,8 +2838,8 @@ sub get_course_adv_roles {
$returnhash{$role}=$username.':'.$domain;
}
} else {
- my $key=&plaintext($role);
- if ($section) { $key.=' (Section '.$section.')'; }
+ my $key=&plaintext($role,$crstype);
+ if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; }
if ($returnhash{$key}) {
$returnhash{$key}.=','.$username.':'.$domain;
} else {
@@ -2630,6 +2873,7 @@ sub get_my_roles {
}
my %returnhash=();
my $now=time;
+ my %privileged;
foreach my $entry (keys(%dumphash)) {
my ($role,$tend,$tstart);
if ($context eq 'userroles') {
@@ -2678,9 +2922,32 @@ sub get_my_roles {
}
}
if ($hidepriv) {
- if ((&privileged($username,$domain)) &&
- (!$nothide{$username.':'.$domain})) {
- next;
+ if ($context eq 'userroles') {
+ if ((&privileged($username,$domain)) &&
+ (!$nothide{$username.':'.$domain})) {
+ next;
+ }
+ } else {
+ unless (ref($privileged{$domain}) eq 'HASH') {
+ my %dompersonnel =
+ &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
+ $privileged{$domain} = {};
+ if (keys(%dompersonnel)) {
+ foreach my $server (keys(%dompersonnel)) {
+ if (ref($dompersonnel{$server}) eq 'HASH') {
+ foreach my $user (keys(%{$dompersonnel{$server}})) {
+ my ($trole,$uname,$udom) = split(/:/,$user);
+ $privileged{$udom}{$uname} = $trole;
+ }
+ }
+ }
+ }
+ }
+ if (exists($privileged{$domain}{$username})) {
+ if (!$nothide{$username.':'.$domain}) {
+ next;
+ }
+ }
}
}
if ($withsec) {
@@ -2728,6 +2995,7 @@ sub getannounce {
sub courseidput {
my ($domain,$storehash,$coursehome,$caller) = @_;
+ return unless (ref($storehash) eq 'HASH');
my $outcome;
if ($caller eq 'timeonly') {
my $cids = '';
@@ -2766,7 +3034,8 @@ sub courseidput {
sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
- $selfenrollonly,$catfilter,$showhidden,$caller)=@_;
+ $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
+ $cloneonly,$createdbefore,$createdafter,$creationcontext)=@_;
my $as_hash = 1;
my %returnhash;
if (!$domfilter) { $domfilter=''; }
@@ -2785,7 +3054,10 @@ sub courseiddump {
':'.&escape($coursefilter).':'.&escape($typefilter).
':'.&escape($regexp_ok).':'.$as_hash.':'.
&escape($selfenrollonly).':'.&escape($catfilter).':'.
- $showhidden.':'.$caller,$tryserver);
+ $showhidden.':'.$caller.':'.&escape($cloner).':'.
+ &escape($cc_clone).':'.$cloneonly.':'.
+ &escape($createdbefore).':'.&escape($createdafter).':'.
+ &escape($creationcontext),$tryserver);
my @pairs=split(/\&/,$rep);
foreach my $item (@pairs) {
my ($key,$value)=split(/\=/,$item,2);
@@ -2800,7 +3072,7 @@ sub courseiddump {
for (my $i=0; $i<@responses; $i++) {
$returnhash{$key}{$items[$i]} = &unescape($responses[$i]);
}
- }
+ }
}
}
}
@@ -2808,6 +3080,49 @@ sub courseiddump {
return %returnhash;
}
+sub courselastaccess {
+ my ($cdom,$cnum,$hostidref) = @_;
+ my %returnhash;
+ if ($cdom && $cnum) {
+ my $chome = &homeserver($cnum,$cdom);
+ if ($chome ne 'no_host') {
+ my $rep = &reply('courselastaccess:'.$cdom.':'.$cnum,$chome);
+ &extract_lastaccess(\%returnhash,$rep);
+ }
+ } else {
+ if (!$cdom) { $cdom=''; }
+ my %libserv = &all_library();
+ foreach my $tryserver (keys(%libserv)) {
+ if (ref($hostidref) eq 'ARRAY') {
+ next unless (grep(/^\Q$tryserver\E$/,@{$hostidref}));
+ }
+ if (($cdom eq '') || (&host_domain($tryserver) eq $cdom)) {
+ my $rep = &reply('courselastaccess:'.&host_domain($tryserver).':',$tryserver);
+ &extract_lastaccess(\%returnhash,$rep);
+ }
+ }
+ }
+ return %returnhash;
+}
+
+sub extract_lastaccess {
+ my ($returnhash,$rep) = @_;
+ if (ref($returnhash) eq 'HASH') {
+ unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' ||
+ $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||
+ $rep eq '') {
+ my @pairs=split(/\&/,$rep);
+ foreach my $item (@pairs) {
+ my ($key,$value)=split(/\=/,$item,2);
+ $key = &unescape($key);
+ next if ($key =~ /^error: 2 /);
+ $returnhash->{$key} = &thaw_unescape($value);
+ }
+ }
+ }
+ return;
+}
+
# ---------------------------------------------------------- DC e-mail
sub dcmailput {
@@ -2840,10 +3155,10 @@ sub dcmaildump {
sub get_domain_roles {
my ($dom,$roles,$startdate,$enddate)=@_;
- if (undef($startdate) || $startdate eq '') {
+ if ((!defined($startdate)) || ($startdate eq '')) {
$startdate = '.';
}
- if (undef($enddate) || $enddate eq '') {
+ if ((!defined($enddate)) || ($enddate eq '')) {
$enddate = '.';
}
my $rolelist;
@@ -2868,7 +3183,7 @@ sub get_domain_roles {
return %personnel;
}
-# ----------------------------------------------------------- Check out an item
+# ----------------------------------------------------------- Interval timing
sub get_first_access {
my ($type,$argsymb)=@_;
@@ -2904,91 +3219,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("<font color=\"blue\">WARNING: ".
- "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
- "</font>");
- 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("<font color=\"blue\">WARNING: ".
- "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
- "</font>");
- }
-
- if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
- &escape('Checkout '.$infostr.' - '.
- $token)) ne 'ok') {
- return '';
- } else {
- &logthis("<font color=\"blue\">WARNING: ".
- "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
- "</font>");
- }
- 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 {
@@ -3250,7 +3480,7 @@ sub tmpreset {
if (tie(%hash,'GDBM_File',
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
&GDBM_WRCREAT(),0640)) {
- foreach my $key (keys %hash) {
+ foreach my $key (keys(%hash)) {
if ($key=~ /:$symb/) {
delete($hash{$key});
}
@@ -3533,7 +3763,10 @@ sub privileged {
my ($username,$domain)=@_;
my $rolesdump=&reply("dump:$domain:$username:roles",
&homeserver($username,$domain));
- if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; }
+ if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||
+ ($rolesdump =~ /^error:/)) {
+ return 0;
+ }
my $now=time;
if ($rolesdump ne '') {
foreach my $entry (split(/&/,$rolesdump)) {
@@ -3561,12 +3794,15 @@ sub privileged {
sub rolesinit {
my ($domain,$username,$authhost)=@_;
+ my $now=time;
+ my %userroles = ('user.login.time' => $now);
my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
- if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
+ if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||
+ ($rolesdump =~ /^error:/)) {
+ return \%userroles;
+ }
my %allroles=();
my %allgroups=();
- my $now=time;
- my %userroles = ('user.login.time' => $now);
my $group_privs;
if ($rolesdump ne '') {
@@ -3632,6 +3868,9 @@ sub custom_roleprivs {
if (($rdummy ne 'con_lost') && ($roledef ne '')) {
my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef);
if (defined($syspriv)) {
+ if ($trest =~ /^$match_community$/) {
+ $syspriv =~ s/bre\&S//;
+ }
$$allroles{'cm./'}.=':'.$syspriv;
$$allroles{$spec.'./'}.=':'.$syspriv;
}
@@ -3685,7 +3924,7 @@ sub set_userprivs {
my $adv=0;
my %grouproles = ();
if (keys(%{$allgroups}) > 0) {
- foreach my $role (keys %{$allroles}) {
+ foreach my $role (keys(%{$allroles})) {
my ($trole,$area,$sec,$extendedarea);
if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {
$trole = $1;
@@ -3728,6 +3967,94 @@ sub set_userprivs {
return ($author,$adv);
}
+sub role_status {
+ my ($rolekey,$then,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
+ my @pwhere = ();
+ if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
+ (undef,undef,$$role,@pwhere)=split(/\./,$rolekey);
+ unless (!defined($$role) || $$role eq '') {
+ $$where=join('.',@pwhere);
+ $$trolecode=$$role.'.'.$$where;
+ ($$tstart,$$tend)=split(/\./,$env{$rolekey});
+ $$tstatus='is';
+ if ($$tstart && $$tstart>$then) {
+ $$tstatus='future';
+ if ($$tstart<$now) {
+ if ($$tstart && $$tstart>$refresh) {
+ if (($$where ne '') && ($$role ne '')) {
+ my (%allroles,%allgroups,$group_privs);
+ my %userroles = (
+ 'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend
+ );
+ my $spec=$$role.'.'.$$where;
+ my ($tdummy,$tdomain,$trest)=split(/\//,$$where);
+ if ($$role =~ /^cr\//) {
+ &custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where);
+ } elsif ($$role eq 'gr') {
+ my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},
+ $env{'user.name'});
+ my $trole = split('_',$rolehash{$$where.'_'.$$role},1);
+ (undef,my $group_privs) = split(/\//,$trole);
+ $group_privs = &unescape($group_privs);
+ &group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);
+ } else {
+ &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
+ }
+ my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups);
+ &appenv(\%userroles,[$$role,'cm']);
+ &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
+ }
+ }
+ $$tstatus = 'is';
+ }
+ }
+ if ($$tend) {
+ if ($$tend<$then) {
+ $$tstatus='expired';
+ } elsif ($$tend<$now) {
+ $$tstatus='will_not';
+ }
+ }
+ }
+ }
+}
+
+sub check_adhoc_privs {
+ my ($cdom,$cnum,$then,$refresh,$now,$checkrole) = @_;
+ 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);
+ unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {
+ &set_adhoc_privileges($cdom,$cnum,$checkrole);
+ }
+ } else {
+ &set_adhoc_privileges($cdom,$cnum,$checkrole);
+ }
+}
+
+sub set_adhoc_privileges {
+# role can be cc or ca
+ my ($dcdom,$pickedcourse,$role) = @_;
+ my $area = '/'.$dcdom.'/'.$pickedcourse;
+ my $spec = $role.'.'.$area;
+ my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
+ $env{'user.name'});
+ my %ccrole = ();
+ &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);
+ my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);
+ &appenv(\%userroles,[$role,'cm']);
+ &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
+ &appenv( {'request.role' => $spec,
+ 'request.role.domain' => $dcdom,
+ 'request.course.sec' => ''
+ }
+ );
+ my $tadv=0;
+ if (&allowed('adv') eq 'F') { $tadv=1; }
+ &appenv({'request.role.adv' => $tadv});
+}
+
# --------------------------------------------------------------- get interface
sub get {
@@ -3763,11 +4090,11 @@ sub del {
foreach my $item (@$storearr) {
$items.=&escape($item).'&';
}
+
$items=~s/\&$//;
if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
-
return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
}
@@ -4188,7 +4515,7 @@ sub get_portfolio_access {
my (%allgroups,%allroles);
my ($start,$end,$role,$sec,$group);
foreach my $envkey (%env) {
- if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
+ if ($envkey =~ m-^user\.role\.(gr|cc|co|in|ta|ep|ad|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
my $cid = $2.'_'.$3;
if ($1 eq 'gr') {
$group = $4;
@@ -4327,6 +4654,219 @@ sub is_portfolio_file {
return;
}
+sub usertools_access {
+ my ($uname,$udom,$tool,$action,$context) = @_;
+ my ($access,%tools);
+ if ($context eq '') {
+ $context = 'tools';
+ }
+ if ($context eq 'requestcourses') {
+ %tools = (
+ official => 1,
+ unofficial => 1,
+ community => 1,
+ );
+ } else {
+ %tools = (
+ aboutme => 1,
+ blog => 1,
+ portfolio => 1,
+ );
+ }
+ return if (!defined($tools{$tool}));
+
+ if ((!defined($udom)) || (!defined($uname))) {
+ $udom = $env{'user.domain'};
+ $uname = $env{'user.name'};
+ }
+
+ if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
+ if ($action ne 'reload') {
+ if ($context eq 'requestcourses') {
+ return $env{'environment.canrequest.'.$tool};
+ } else {
+ return $env{'environment.availabletools.'.$tool};
+ }
+ }
+ }
+
+ my ($toolstatus,$inststatus);
+
+ if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
+ ($action ne 'reload')) {
+ $toolstatus = $env{'environment.'.$context.'.'.$tool};
+ $inststatus = $env{'environment.inststatus'};
+ } else {
+ my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');
+ $toolstatus = $userenv{$context.'.'.$tool};
+ $inststatus = $userenv{'inststatus'};
+ }
+
+ if ($toolstatus ne '') {
+ if ($toolstatus) {
+ $access = 1;
+ } else {
+ $access = 0;
+ }
+ return $access;
+ }
+
+ my $is_adv = &is_advanced_user($udom,$uname);
+ my %domdef = &get_domain_defaults($udom);
+ if (ref($domdef{$tool}) eq 'HASH') {
+ if ($is_adv) {
+ if ($domdef{$tool}{'_LC_adv'} ne '') {
+ if ($domdef{$tool}{'_LC_adv'}) {
+ $access = 1;
+ } else {
+ $access = 0;
+ }
+ return $access;
+ }
+ }
+ if ($inststatus ne '') {
+ my ($hasaccess,$hasnoaccess);
+ foreach my $affiliation (split(/:/,$inststatus)) {
+ if ($domdef{$tool}{$affiliation} ne '') {
+ if ($domdef{$tool}{$affiliation}) {
+ $hasaccess = 1;
+ } else {
+ $hasnoaccess = 1;
+ }
+ }
+ }
+ if ($hasaccess || $hasnoaccess) {
+ if ($hasaccess) {
+ $access = 1;
+ } elsif ($hasnoaccess) {
+ $access = 0;
+ }
+ return $access;
+ }
+ } else {
+ if ($domdef{$tool}{'default'} ne '') {
+ if ($domdef{$tool}{'default'}) {
+ $access = 1;
+ } elsif ($domdef{$tool}{'default'} == 0) {
+ $access = 0;
+ }
+ return $access;
+ }
+ }
+ } else {
+ if ($context eq 'tools') {
+ $access = 1;
+ } else {
+ $access = 0;
+ }
+ return $access;
+ }
+}
+
+sub is_course_owner {
+ my ($cdom,$cnum,$udom,$uname) = @_;
+ if (($udom eq '') || ($uname eq '')) {
+ $udom = $env{'user.domain'};
+ $uname = $env{'user.name'};
+ }
+ unless (($udom eq '') || ($uname eq '')) {
+ if (exists($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'})) {
+ if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) {
+ return 1;
+ } else {
+ my %courseinfo = &Apache::lonnet::coursedescription($cdom.'/'.$cnum);
+ if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) {
+ return 1;
+ }
+ }
+ }
+ }
+ return;
+}
+
+sub is_advanced_user {
+ my ($udom,$uname) = @_;
+ my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
+ my %allroles;
+ my $is_adv;
+ foreach my $role (keys(%roleshash)) {
+ my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);
+ my $area = '/'.$tdomain.'/'.$trest;
+ if ($sec ne '') {
+ $area .= '/'.$sec;
+ }
+ if (($area ne '') && ($trole ne '')) {
+ my $spec=$trole.'.'.$area;
+ if ($trole =~ /^cr\//) {
+ &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
+ } elsif ($trole ne 'gr') {
+ &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
+ }
+ }
+ }
+ foreach my $role (keys(%allroles)) {
+ last if ($is_adv);
+ foreach my $item (split(/:/,$allroles{$role})) {
+ if ($item ne '') {
+ my ($privilege,$restrictions)=split(/&/,$item);
+ if ($privilege eq 'adv') {
+ $is_adv = 1;
+ last;
+ }
+ }
+ }
+ }
+ return $is_adv;
+}
+
+sub check_can_request {
+ my ($dom,$can_request,$request_domains) = @_;
+ my $canreq = 0;
+ my ($types,$typename) = &Apache::loncommon::course_types();
+ my @options = ('approval','validate','autolimit');
+ my $optregex = join('|',@options);
+ if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
+ foreach my $type (@{$types}) {
+ if (&usertools_access($env{'user.name'},
+ $env{'user.domain'},
+ $type,undef,'requestcourses')) {
+ $canreq ++;
+ if (ref($request_domains) eq 'HASH') {
+ push(@{$request_domains->{$type}},$env{'user.domain'});
+ }
+ if ($dom eq $env{'user.domain'}) {
+ $can_request->{$type} = 1;
+ }
+ }
+ if ($env{'environment.reqcrsotherdom.'.$type} ne '') {
+ my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});
+ if (@curr > 0) {
+ foreach my $item (@curr) {
+ if (ref($request_domains) eq 'HASH') {
+ my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);
+ if ($otherdom ne '') {
+ if (ref($request_domains->{$type}) eq 'ARRAY') {
+ unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {
+ push(@{$request_domains->{$type}},$otherdom);
+ }
+ } else {
+ push(@{$request_domains->{$type}},$otherdom);
+ }
+ }
+ }
+ }
+ unless($dom eq $env{'user.domain'}) {
+ $canreq ++;
+ if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {
+ $can_request->{$type} = 1;
+ }
+ }
+ }
+ }
+ }
+ }
+ return $canreq;
+}
# ---------------------------------------------- Custom access rule evaluation
@@ -4482,17 +5022,68 @@ sub allowed {
my $statecond=0;
my $courseprivid='';
+ my $ownaccess;
+ # Community Coordinator or Assistant Co-author browsing resource space.
+ if (($priv eq 'bro') && ($env{'user.author'})) {
+ if ($uri eq '') {
+ $ownaccess = 1;
+ } else {
+ if (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) {
+ my $udom = $env{'user.domain'};
+ my $uname = $env{'user.name'};
+ if ($uri =~ m{^\Q$udom\E/?$}) {
+ $ownaccess = 1;
+ } elsif ($uri =~ m{^\Q$udom\E/\Q$uname\E/?}) {
+ unless ($uri =~ m{\.\./}) {
+ $ownaccess = 1;
+ }
+ } elsif (($udom ne 'public') && ($uname ne 'public')) {
+ my $now = time;
+ if ($uri =~ m{^([^/]+)/?$}) {
+ my $adom = $1;
+ foreach my $key (keys(%env)) {
+ if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) {
+ my ($start,$end) = split('.',$env{$key});
+ if (($now >= $start) && (!$end || $end < $now)) {
+ $ownaccess = 1;
+ last;
+ }
+ }
+ }
+ } elsif ($uri =~ m{^([^/]+)/([^/]+)/?}) {
+ my $adom = $1;
+ my $aname = $2;
+ foreach my $role ('ca','aa') {
+ if ($env{"user.role.$role./$adom/$aname"}) {
+ my ($start,$end) =
+ split('.',$env{"user.role.$role./$adom/$aname"});
+ if (($now >= $start) && (!$end || $end < $now)) {
+ $ownaccess = 1;
+ last;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+
# Course
if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {
- $thisallowed.=$1;
+ unless (($priv eq 'bro') && (!$ownaccess)) {
+ $thisallowed.=$1;
+ }
}
# Domain
if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
=~/\Q$priv\E\&([^\:]*)/) {
- $thisallowed.=$1;
+ unless (($priv eq 'bro') && (!$ownaccess)) {
+ $thisallowed.=$1;
+ }
}
# Course: uri itself is a course
@@ -4502,7 +5093,9 @@ sub allowed {
if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}
=~/\Q$priv\E\&([^\:]*)/) {
- $thisallowed.=$1;
+ unless (($priv eq 'bro') && (!$ownaccess)) {
+ $thisallowed.=$1;
+ }
}
# URI is an uploaded document for this course, default permissions don't matter
@@ -4642,7 +5235,7 @@ sub allowed {
my $envkey;
if ($thisallowed=~/L/) {
- foreach $envkey (keys %env) {
+ foreach $envkey (keys(%env)) {
if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
my $courseid=$2;
my $roleid=$1.'.'.$2;
@@ -4891,6 +5484,9 @@ sub log_query {
sub update_portfolio_table {
my ($uname,$udom,$file_name,$query,$group,$action) = @_;
+ if ($group ne '') {
+ $file_name =~s /^\Q$group\E//;
+ }
my $homeserver = &homeserver($uname,$udom);
my $queryid=
&reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
@@ -4930,7 +5526,7 @@ sub fetch_enrollment_query {
}
my $host=&hostname($homeserver);
my $cmd = '';
- foreach my $affiliate (keys %{$affiliatesref}) {
+ foreach my $affiliate (keys(%{$affiliatesref})) {
$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
}
$cmd =~ s/%%$//;
@@ -5063,11 +5659,21 @@ sub auto_run {
sub auto_get_sections {
my ($cnum,$cdom,$inst_coursecode) = @_;
- my $homeserver = &homeserver($cnum,$cdom);
- my @secs = ();
- my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
- unless ($response eq 'refused') {
- @secs = split(/:/,$response);
+ my $homeserver;
+ if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
+ $homeserver = &homeserver($cnum,$cdom);
+ }
+ if (!defined($homeserver)) {
+ if ($cdom =~ /^$match_domain$/) {
+ $homeserver = &domain($cdom,'primary');
+ }
+ }
+ my @secs;
+ if (defined($homeserver)) {
+ my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
+ unless ($response eq 'refused') {
+ @secs = split(/:/,$response);
+ }
}
return @secs;
}
@@ -5086,6 +5692,23 @@ sub auto_validate_courseID {
return $response;
}
+sub auto_validate_instcode {
+ my ($cnum,$cdom,$instcode,$owner) = @_;
+ my ($homeserver,$response);
+ if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
+ $homeserver = &homeserver($cnum,$cdom);
+ }
+ if (!defined($homeserver)) {
+ if ($cdom =~ /^$match_domain$/) {
+ $homeserver = &domain($cdom,'primary');
+ }
+ }
+ my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
+ &escape($instcode).':'.&escape($owner),$homeserver));
+ my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);
+ return ($outcome,$description);
+}
+
sub auto_create_password {
my ($cnum,$cdom,$authparam,$udom) = @_;
my ($homeserver,$response);
@@ -5200,6 +5823,13 @@ sub auto_instcode_format {
push(@homeservers,$tryserver);
}
}
+ } elsif ($caller eq 'requests') {
+ if ($codedom =~ /^$match_domain$/) {
+ my $chome = &domain($codedom,'primary');
+ unless ($chome eq 'no_host') {
+ push(@homeservers,$chome);
+ }
+ }
} else {
push(@homeservers,&homeserver($caller,$codedom));
}
@@ -5257,7 +5887,81 @@ sub auto_instcode_defaults {
}
return $response;
-}
+}
+
+sub auto_possible_instcodes {
+ my ($domain,$codetitles,$cat_titles,$cat_orders,$code_order) = @_;
+ unless ((ref($codetitles) eq 'ARRAY') && (ref($cat_titles) eq 'HASH') &&
+ (ref($cat_orders) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {
+ return;
+ }
+ my (@homeservers,$uhome);
+ if (defined(&domain($domain,'primary'))) {
+ $uhome=&domain($domain,'primary');
+ push(@homeservers,&domain($domain,'primary'));
+ } else {
+ my %servers = &get_servers($domain,'library');
+ foreach my $tryserver (keys(%servers)) {
+ if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
+ push(@homeservers,$tryserver);
+ }
+ }
+ }
+ my $response;
+ foreach my $server (@homeservers) {
+ $response=&reply('autopossibleinstcodes:'.$domain,$server);
+ next if ($response =~ /(con_lost|error|no_such_host|refused)/);
+ my ($codetitlestr,$codeorderstr,$cat_title,$cat_order) =
+ split(':',$response);
+ @{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr));
+ @{$code_order} = map { &unescape($_); } (split('&',$codeorderstr));
+ foreach my $item (split('&',$cat_title)) {
+ my ($name,$value)=split('=',$item);
+ $cat_titles->{&unescape($name)}=&thaw_unescape($value);
+ }
+ foreach my $item (split('&',$cat_order)) {
+ my ($name,$value)=split('=',$item);
+ $cat_orders->{&unescape($name)}=&thaw_unescape($value);
+ }
+ return 'ok';
+ }
+ return $response;
+}
+
+sub auto_courserequest_checks {
+ my ($dom) = @_;
+ my ($homeserver,%validations);
+ if ($dom =~ /^$match_domain$/) {
+ $homeserver = &domain($dom,'primary');
+ }
+ unless ($homeserver eq 'no_host') {
+ my $response=&reply('autocrsreqchecks:'.$dom,$homeserver);
+ unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
+ my @items = split(/&/,$response);
+ foreach my $item (@items) {
+ my ($key,$value) = split('=',$item);
+ $validations{&unescape($key)} = &thaw_unescape($value);
+ }
+ }
+ }
+ return %validations;
+}
+
+sub auto_courserequest_validation {
+ my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_;
+ my ($homeserver,$response);
+ if ($dom =~ /^$match_domain$/) {
+ $homeserver = &domain($dom,'primary');
+ }
+ unless ($homeserver eq 'no_host') {
+
+ $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).
+ ':'.&escape($crstype).':'.&escape($inststatuslist).
+ ':'.&escape($instcode).':'.&escape($instseclist),
+ $homeserver));
+ }
+ return $response;
+}
sub auto_validate_class_sec {
my ($cdom,$cnum,$owners,$inst_class) = @_;
@@ -5410,28 +6114,38 @@ sub devalidate_getgroups_cache {
# ------------------------------------------------------------------ Plain Text
sub plaintext {
- my ($short,$type,$cid) = @_;
- if ($short =~ /^cr/) {
+ my ($short,$type,$cid,$forcedefault) = @_;
+ if ($short =~ m{^cr/}) {
return (split('/',$short))[-1];
}
if (!defined($cid)) {
$cid = $env{'request.course.id'};
}
- if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) {
- return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short.
- '.plaintext'});
- }
my %rolenames = (
- Course => 'std',
- Group => 'alt1',
+ Course => 'std',
+ Community => 'alt1',
);
- if (defined($type) &&
- defined($rolenames{$type}) &&
- defined($prp{$short}{$rolenames{$type}})) {
+ if ($cid ne '') {
+ if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') {
+ unless ($forcedefault) {
+ my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'};
+ &Apache::lonlocal::mt_escape(\$roletext);
+ return &Apache::lonlocal::mt($roletext);
+ }
+ }
+ }
+ if ((defined($type)) && (defined($rolenames{$type})) &&
+ (defined($rolenames{$type})) &&
+ (defined($prp{$short}{$rolenames{$type}}))) {
return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});
- } else {
- return &Apache::lonlocal::mt($prp{$short}{'std'});
+ } elsif ($cid ne '') {
+ my $crstype = $env{'course.'.$cid.'.type'};
+ if (($crstype ne '') && (defined($rolenames{$crstype})) &&
+ (defined($prp{$short}{$rolenames{$crstype}}))) {
+ return &Apache::lonlocal::mt($prp{$short}{$rolenames{$crstype}});
+ }
}
+ return &Apache::lonlocal::mt($prp{$short}{'std'});
}
# ----------------------------------------------------------------- Assign Role
@@ -5444,10 +6158,27 @@ sub assignrole {
my $cwosec=$url;
$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
unless (&allowed('ccr',$cwosec)) {
- &logthis('Refused custom assignrole: '.
- $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
- $env{'user.name'}.' at '.$env{'user.domain'});
- return 'refused';
+ my $refused = 1;
+ if ($context eq 'requestcourses') {
+ if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
+ if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {
+ if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {
+ my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
+ my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
+ if ($crsenv{'internal.courseowner'} eq
+ $env{'user.name'}.':'.$env{'user.domain'}) {
+ $refused = '';
+ }
+ }
+ }
+ }
+ }
+ if ($refused) {
+ &logthis('Refused custom assignrole: '.
+ $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.
+ ' by '.$env{'user.name'}.' at '.$env{'user.domain'});
+ return 'refused';
+ }
}
$mrole='cr';
} elsif ($role =~ /^gr\//) {
@@ -5473,9 +6204,48 @@ sub assignrole {
$refused = 1;
}
if ($refused) {
- if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
+ my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
+ if (!$selfenroll && $context eq 'course') {
+ my %crsenv;
+ if ($role eq 'cc' || $role eq 'co') {
+ %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
+ if (($role eq 'cc') && ($cnum !~ /^$match_community$/)) {
+ if ($env{'request.role'} eq 'cc./'.$cdom.'/'.$cnum) {
+ if ($crsenv{'internal.courseowner'} eq
+ $env{'user.name'}.':'.$env{'user.domain'}) {
+ $refused = '';
+ }
+ }
+ } elsif (($role eq 'co') && ($cnum =~ /^$match_community$/)) {
+ if ($env{'request.role'} eq 'co./'.$cdom.'/'.$cnum) {
+ if ($crsenv{'internal.courseowner'} eq
+ $env{'user.name'}.':'.$env{'user.domain'}) {
+ $refused = '';
+ }
+ }
+ }
+ }
+ } elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
$refused = '';
- } else {
+ } elsif ($context eq 'requestcourses') {
+ my @possroles = ('st','ta','ep','in','cc','co');
+ if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
+ my $wrongcc;
+ if ($cnum =~ /^$match_community$/) {
+ $wrongcc = 1 if ($role eq 'cc');
+ } else {
+ $wrongcc = 1 if ($role eq 'co');
+ }
+ unless ($wrongcc) {
+ my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
+ if ($crsenv{'internal.courseowner'} eq
+ $env{'user.name'}.':'.$env{'user.domain'}) {
+ $refused = '';
+ }
+ }
+ }
+ }
+ if ($refused) {
&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
' '.$role.' '.$end.' '.$start.' by '.
$env{'user.name'}.' at '.$env{'user.domain'});
@@ -5522,10 +6292,97 @@ sub assignrole {
&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
$origstart,$selfenroll,$context);
}
+ if ($role eq 'cc') {
+ &autoupdate_coowners($url,$end,$start,$uname,$udom);
+ }
}
return $answer;
}
+sub autoupdate_coowners {
+ my ($url,$end,$start,$uname,$udom) = @_;
+ my ($cdom,$cnum) = ($url =~ m{^/($match_domain)/($match_courseid)});
+ if (($cdom ne '') && ($cnum ne '')) {
+ my $now = time;
+ my %domdesign = &Apache::loncommon::get_domainconf($cdom);
+ if ($domdesign{$cdom.'.autoassign.co-owners'}) {
+ my %coursehash = &coursedescription($cdom.'_'.$cnum);
+ my $instcode = $coursehash{'internal.coursecode'};
+ if ($instcode ne '') {
+ if (($start && $start <= $now) && ($end == 0) || ($end > $now)) {
+ unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {
+ my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);
+ my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);
+ if ($result eq 'valid') {
+ if ($coursehash{'internal.co-owners'}) {
+ foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
+ push(@newcoowners,$coowner);
+ }
+ unless (grep(/^\Q$uname\E:\Q$udom\E$/,@newcoowners)) {
+ push(@newcoowners,$uname.':'.$udom);
+ }
+ @newcoowners = sort(@newcoowners);
+ } else {
+ push(@newcoowners,$uname.':'.$udom);
+ }
+ } else {
+ if ($coursehash{'internal.co-owners'}) {
+ foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
+ unless ($coowner eq $uname.':'.$udom) {
+ push(@newcoowners,$coowner);
+ }
+ }
+ unless (@newcoowners > 0) {
+ $delcoowners = 1;
+ $coowners = '';
+ }
+ }
+ }
+ if (@newcoowners || $delcoowners) {
+ &store_coowners($cdom,$cnum,$coursehash{'home'},
+ $delcoowners,@newcoowners);
+ }
+ }
+ }
+ }
+ }
+ }
+}
+
+sub store_coowners {
+ my ($cdom,$cnum,$chome,$delcoowners,@newcoowners) = @_;
+ my $cid = $cdom.'_'.$cnum;
+ my ($coowners,$delresult,$putresult);
+ if (@newcoowners) {
+ $coowners = join(',',@newcoowners);
+ my %coownershash = (
+ 'internal.co-owners' => $coowners,
+ );
+ $putresult = &put('environment',\%coownershash,$cdom,$cnum);
+ if ($putresult eq 'ok') {
+ if ($env{'course.'.$cid.'.num'} eq $cnum) {
+ &appenv({'course.'.$cid.'.internal.co-owners' => $coowners});
+ }
+ }
+ }
+ if ($delcoowners) {
+ $delresult = &Apache::lonnet::del('environment',['internal.co-owners'],$cdom,$cnum);
+ if ($delresult eq 'ok') {
+ if ($env{'course.'.$cid.'.internal.co-owners'}) {
+ &Apache::lonnet::delenv('course.'.$cid.'.internal.co-owners');
+ }
+ }
+ }
+ if (($putresult eq 'ok') || ($delresult eq 'ok')) {
+ my %crsinfo =
+ &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.');
+ if (ref($crsinfo{$cid}) eq 'HASH') {
+ $crsinfo{$cid}{'co-owners'} = \@newcoowners;
+ my $cidput = &Apache::lonnet::courseidput($cdom,\%crsinfo,$chome,'notime');
+ }
+ }
+}
+
# -------------------------------------------------- Modify user authentication
# Overrides without validation
@@ -5558,12 +6415,18 @@ sub modifyuser {
my ($udom, $uname, $uid,
$umode, $upass, $first,
$middle, $last, $gene,
- $forceid, $desiredhome, $email, $inststatus)=@_;
+ $forceid, $desiredhome, $email, $inststatus, $candelete)=@_;
$udom= &LONCAPA::clean_domain($udom);
$uname=&LONCAPA::clean_username($uname);
+ my $showcandelete = 'none';
+ if (ref($candelete) eq 'ARRAY') {
+ if (@{$candelete} > 0) {
+ $showcandelete = join(', ',@{$candelete});
+ }
+ }
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.
- $last.', '.$gene.'(forceid: '.$forceid.')'.
+ $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'.
(defined($desiredhome) ? ' desiredhome = '.$desiredhome :
' desiredhome not specified').
' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
@@ -5628,9 +6491,33 @@ sub modifyuser {
%names = @tmp;
}
#
-# Make sure to not trash student environment if instructor does not bother
-# to supply name and email information
-#
+# If name, email and/or uid are blank (e.g., because an uploaded file
+# of users did not contain them), do not overwrite existing values
+# unless field is in $candelete array ref.
+#
+
+ my @fields = ('firstname','middlename','lastname','generation',
+ 'permanentemail','id');
+ my %newvalues;
+ if (ref($candelete) eq 'ARRAY') {
+ foreach my $field (@fields) {
+ if (grep(/^\Q$field\E$/,@{$candelete})) {
+ if ($field eq 'firstname') {
+ $names{$field} = $first;
+ } elsif ($field eq 'middlename') {
+ $names{$field} = $middle;
+ } elsif ($field eq 'lastname') {
+ $names{$field} = $last;
+ } elsif ($field eq 'generation') {
+ $names{$field} = $gene;
+ } elsif ($field eq 'permanentemail') {
+ $names{$field} = $email;
+ } elsif ($field eq 'id') {
+ $names{$field} = $uid;
+ }
+ }
+ }
+ }
if ($first) { $names{'firstname'} = $first; }
if (defined($middle)) { $names{'middlename'} = $middle; }
if ($last) { $names{'lastname'} = $last; }
@@ -5640,7 +6527,21 @@ sub modifyuser {
if ($email=~/\@/) { $names{'permanentemail'} = $email; }
}
if ($uid) { $names{'id'} = $uid; }
- if (defined($inststatus)) { $names{'inststatus'} = $inststatus; }
+ if (defined($inststatus)) {
+ $names{'inststatus'} = '';
+ my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom);
+ if (ref($usertypes) eq 'HASH') {
+ my @okstatuses;
+ foreach my $item (split(/:/,$inststatus)) {
+ if (defined($usertypes->{$item})) {
+ push(@okstatuses,$item);
+ }
+ }
+ if (@okstatuses) {
+ $names{'inststatus'} = join(':', map { &escape($_); } @okstatuses);
+ }
+ }
+ }
my $reply = &put('environment', \%names, $udom,$uname);
if ($reply ne 'ok') { return 'error: '.$reply; }
my $sqlresult = &update_allusers_table($uname,$udom,\%names);
@@ -5662,7 +6563,7 @@ sub modifyuser {
sub modifystudent {
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
$end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
- $selfenroll,$context)=@_;
+ $selfenroll,$context,$inststatus)=@_;
if (!$cid) {
unless ($cid=$env{'request.course.id'}) {
return 'not_in_class';
@@ -5671,7 +6572,7 @@ sub modifystudent {
# --------------------------------------------------------------- Make the user
my $reply=&modifyuser
($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
- $desiredhome,$email);
+ $desiredhome,$email,$inststatus);
unless ($reply eq 'ok') { return $reply; }
# This will cause &modify_student_enrollment to get the uid from the
# students environment
@@ -5785,48 +6686,90 @@ sub writecoursepref {
sub createcourse {
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
- $course_owner,$crstype)=@_;
+ $course_owner,$crstype,$cnum,$context,$category)=@_;
$url=&declutter($url);
my $cid='';
- unless (&allowed('ccc',$udom)) {
+ if ($context eq 'requestcourses') {
+ my $can_create = 0;
+ my ($ownername,$ownerdom) = split(':',$course_owner);
+ if ($udom eq $ownerdom) {
+ if (&usertools_access($ownername,$ownerdom,$category,undef,
+ $context)) {
+ $can_create = 1;
+ }
+ } else {
+ my %userenv = &userenvironment($ownerdom,$ownername,'reqcrsotherdom.'.
+ $category);
+ if ($userenv{'reqcrsotherdom.'.$category} ne '') {
+ my @curr = split(',',$userenv{'reqcrsotherdom.'.$category});
+ if (@curr > 0) {
+ my @options = qw(approval validate autolimit);
+ my $optregex = join('|',@options);
+ if (grep(/^\Q$udom\E:($optregex)(=?\d*)$/,@curr)) {
+ $can_create = 1;
+ }
+ }
+ }
+ }
+ if ($can_create) {
+ unless ($ownername eq $env{'user.name'} && $ownerdom eq $env{'user.domain'}) {
+ unless (&allowed('ccc',$udom)) {
+ return 'refused';
+ }
+ }
+ } else {
+ return 'refused';
+ }
+ } elsif (!&allowed('ccc',$udom)) {
return 'refused';
}
-# ------------------------------------------------------------------- Create ID
- my $uname=int(1+rand(9)).
- ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
- substr($$.time,0,5).unpack("H8",pack("I32",time)).
- unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
-# ----------------------------------------------- Make sure that does not exist
- my $uhome=&homeserver($uname,$udom,'true');
- unless (($uhome eq '') || ($uhome eq 'no_host')) {
- $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
- unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
- $uhome=&homeserver($uname,$udom,'true');
- unless (($uhome eq '') || ($uhome eq 'no_host')) {
- return 'error: unable to generate unique course-ID';
- }
- }
-# ------------------------------------------------ Check supplied server name
- $course_server = $env{'user.homeserver'} if (! defined($course_server));
- if (! &is_library($course_server)) {
- return 'error:bad server name '.$course_server;
+# --------------------------------------------------------------- Get Unique ID
+ my $uname;
+ if ($cnum =~ /^$match_courseid$/) {
+ my $chome=&homeserver($cnum,$udom,'true');
+ if (($chome eq '') || ($chome eq 'no_host')) {
+ $uname = $cnum;
+ } else {
+ $uname = &generate_coursenum($udom,$crstype);
+ }
+ } else {
+ $uname = &generate_coursenum($udom,$crstype);
+ }
+ return $uname if ($uname =~ /^error/);
+# -------------------------------------------------- Check supplied server name
+ if (!defined($course_server)) {
+ if (defined(&domain($udom,'primary'))) {
+ $course_server = &domain($udom,'primary');
+ } else {
+ $course_server = $env{'user.home'};
+ }
+ }
+ my %host_servers =
+ &Apache::lonnet::get_servers($udom,'library');
+ unless ($host_servers{$course_server}) {
+ return 'error: invalid home server for course: '.$course_server;
}
# ------------------------------------------------------------- Make the course
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
$course_server);
unless ($reply eq 'ok') { return 'error: '.$reply; }
- $uhome=&homeserver($uname,$udom,'true');
+ my $uhome=&homeserver($uname,$udom,'true');
if (($uhome eq '') || ($uhome eq 'no_host')) {
return 'error: no such course';
}
# ----------------------------------------------------------------- Course made
# log existence
+ my $now = time;
my $newcourse = {
$udom.'_'.$uname => {
description => $description,
inst_code => $inst_code,
owner => $course_owner,
type => $crstype,
+ creator => $env{'user.name'}.':'.
+ $env{'user.domain'},
+ created => $now,
+ context => $context,
},
};
&courseidput($udom,$newcourse,$uhome,'notime');
@@ -5851,11 +6794,51 @@ ENDINITMAP
}
# ----------------------------------------------------------- Write preferences
&writecoursepref($udom.'_'.$uname,
- ('description' => $description,
- 'url' => $topurl));
+ ('description' => $description,
+ 'url' => $topurl,
+ 'internal.creator' => $env{'user.name'}.':'.
+ $env{'user.domain'},
+ 'internal.created' => $now,
+ 'internal.creationcontext' => $context)
+ );
return '/'.$udom.'/'.$uname;
}
+# ------------------------------------------------------------------- Create ID
+sub generate_coursenum {
+ my ($udom,$crstype) = @_;
+ my $domdesc = &domain($udom);
+ return 'error: invalid domain' if ($domdesc eq '');
+ my $first;
+ if ($crstype eq 'Community') {
+ $first = '0';
+ } else {
+ $first = int(1+rand(9));
+ }
+ my $uname=$first.
+ ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
+ substr($$.time,0,5).unpack("H8",pack("I32",time)).
+ unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
+# ----------------------------------------------- Make sure that does not exist
+ my $uhome=&homeserver($uname,$udom,'true');
+ unless (($uhome eq '') || ($uhome eq 'no_host')) {
+ if ($crstype eq 'Community') {
+ $first = '0';
+ } else {
+ $first = int(1+rand(9));
+ }
+ $uname=$first.
+ ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
+ substr($$.time,0,5).unpack("H8",pack("I32",time)).
+ unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
+ $uhome=&homeserver($uname,$udom,'true');
+ unless (($uhome eq '') || ($uhome eq 'no_host')) {
+ return 'error: unable to generate unique course-ID';
+ }
+ }
+ return $uname;
+}
+
sub is_course {
my ($cdom,$cnum) = @_;
my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
@@ -5866,6 +6849,39 @@ sub is_course {
return 0;
}
+sub store_userdata {
+ my ($storehash,$datakey,$namespace,$udom,$uname) = @_;
+ my $result;
+ if ($datakey ne '') {
+ if (ref($storehash) eq 'HASH') {
+ if ($udom eq '' || $uname eq '') {
+ $udom = $env{'user.domain'};
+ $uname = $env{'user.name'};
+ }
+ my $uhome=&homeserver($uname,$udom);
+ if (($uhome eq '') || ($uhome eq 'no_host')) {
+ $result = 'error: no_host';
+ } else {
+ $storehash->{'ip'} = $ENV{'REMOTE_ADDR'};
+ $storehash->{'host'} = $perlvar{'lonHostID'};
+
+ my $namevalue='';
+ foreach my $key (keys(%{$storehash})) {
+ $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
+ }
+ $namevalue=~s/\&$//;
+ $result = &reply("store:$env{'user.domain'}:$env{'user.name'}:".
+ "$namespace:$datakey:$namevalue",$uhome);
+ }
+ } else {
+ $result = 'error: data to store was not a hash reference';
+ }
+ } else {
+ $result= 'error: invalid requestkey';
+ }
+ return $result;
+}
+
# ---------------------------------------------------------- Assign Custom Role
sub assigncustomrole {
@@ -6144,20 +7160,18 @@ sub modify_access_controls {
}
}
}
+ my ($group);
+ if (&is_course($domain,$user)) {
+ ($group,my $file) = split(/\//,$file_name,2);
+ }
$deloutcome = &del('file_permissions',\@deletions,$domain,$user);
$new_values{$file_name."\0".'accesscontrol'} = \%new_control;
$outcome = &put('file_permissions',\%new_values,$domain,$user);
# remove lock
my @del_lock = ($file_name."\0".'locked_access_records');
my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
- my ($file,$group);
- if (&is_course($domain,$user)) {
- ($group,$file) = split(/\//,$file_name,2);
- } else {
- $file = $file_name;
- }
my $sqlresult =
- &update_portfolio_table($user,$domain,$file,'portfolio_access',
+ &update_portfolio_table($user,$domain,$file_name,'portfolio_access',
$group);
} else {
$outcome = "error: could not obtain lockfile\n";
@@ -7357,6 +8371,11 @@ sub devalidate_title_cache {
&devalidate_cache_new('title',$key);
}
+# ------------------------------------------------- Get the title of a course
+
+sub current_course_title {
+ return $env{ 'course.' . $env{'request.course.id'} . '.description' };
+}
# ------------------------------------------------- Get the title of a resource
sub gettitle {
@@ -7423,7 +8442,7 @@ sub symblist {
if (($env{'request.course.fn'}) && (%newhash)) {
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
&GDBM_WRCREAT(),0640)) {
- foreach my $url (keys %newhash) {
+ foreach my $url (keys(%newhash)) {
next if ($url eq 'last_known'
&& $env{'form.no_update_last_known'});
$hash{declutter($url)}=&encode_symb($mapname,
@@ -7460,6 +8479,9 @@ sub symbverify {
if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
&GDBM_READER(),0640)) {
+ if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {
+ $thisurl =~ s/\?.+$//;
+ }
my $ids=$bighash{'ids_'.&clutter($thisurl)};
unless ($ids) {
$ids=$bighash{'ids_/'.$thisurl};
@@ -7468,6 +8490,9 @@ sub symbverify {
# ------------------------------------------------------------------- Has ID(s)
foreach my $id (split(/\,/,$ids)) {
my ($mapid,$resid)=split(/\./,$id);
+ if ($thisfn =~ m{^/adm/wrapper/ext/}) {
+ $symb =~ s/\?.+$//;
+ }
if (
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
eq $symb) {
@@ -8130,7 +9155,10 @@ sub repcopy_userfile {
if (-e $transferfile) { return 'ok'; }
my $request;
$uri=~s/^\///;
- $request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);
+ my $homeserver = &homeserver($cnum,$cdom);
+ my $protocol = $protocol{$homeserver};
+ $protocol = 'http' if ($protocol ne 'https');
+ $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri);
my $response=$ua->request($request,$transferfile);
# did it work?
if ($response->is_error()) {
@@ -8145,7 +9173,7 @@ sub repcopy_userfile {
sub tokenwrapper {
my $uri=shift;
- $uri=~s|^http\://([^/]+)||;
+ $uri=~s|^https?\://([^/]+)||;
$uri=~s|^/||;
$env{'user.environment'}=~/\/([^\/]+)\.id/;
my $token=$1;
@@ -8153,7 +9181,10 @@ sub tokenwrapper {
if ($udom && $uname && $file) {
$file=~s|(\?\.*)*$||;
&appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
- return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.
+ my $homeserver = &homeserver($uname,$udom);
+ my $protocol = $protocol{$homeserver};
+ $protocol = 'http' if ($protocol ne 'https');
+ return $protocol.'://'.&hostname($homeserver).'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};
} else {
@@ -8168,7 +9199,10 @@ sub tokenwrapper {
sub getuploaded {
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
$uri=~s/^\///;
- $uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri;
+ my $homeserver = &homeserver($cnum,$cdom);
+ my $protocol = $protocol{$homeserver};
+ $protocol = 'http' if ($protocol ne 'https');
+ $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;
my $ua=new LWP::UserAgent;
my $request=new HTTP::Request($reqtype,$uri);
my $response=$ua->request($request);
@@ -8250,7 +9284,7 @@ sub filelocation {
sub hreflocation {
my ($dir,$file)=@_;
- unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
+ unless (($file=~m-^https?\://-i) || ($file=~m-^/-)) {
$file=filelocation($dir,$file);
} elsif ($file=~m-^/adm/-) {
$file=~s-^/adm/wrapper/-/-;
@@ -8335,7 +9369,9 @@ sub declutter {
$thisfn=~s|^adm/wrapper/||;
$thisfn=~s|^adm/coursedocs/showdoc/||;
$thisfn=~s/^res\///;
- $thisfn=~s/\?.+$//;
+ unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) {
+ $thisfn=~s/\?.+$//;
+ }
return $thisfn;
}
@@ -8347,8 +9383,8 @@ sub clutter {
|| $thisfn =~ m{^/adm/(includes|pages)} ) {
$thisfn='/res'.$thisfn;
}
- if ($thisfn !~m|/adm|) {
- if ($thisfn =~ m|/ext/|) {
+ if ($thisfn !~m|^/adm|) {
+ if ($thisfn =~ m|^/ext/|) {
$thisfn='/adm/wrapper'.$thisfn;
} else {
my ($ext) = ($thisfn =~ /\.(\w+)$/);
@@ -8446,14 +9482,19 @@ sub get_dns {
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
foreach my $dns (<$config>) {
next if ($dns !~ /^\^(\S*)/x);
- $alldns{$1} = 1;
+ my $line = $1;
+ my ($host,$protocol) = split(/:/,$line);
+ if ($protocol ne 'https') {
+ $protocol = 'http';
+ }
+ $alldns{$host} = $protocol;
}
while (%alldns) {
my ($dns) = keys(%alldns);
- delete($alldns{$dns});
my $ua=new LWP::UserAgent;
- my $request=new HTTP::Request('GET',"http://$dns$url");
+ my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
my $response=$ua->request($request);
+ delete($alldns{$dns});
next if ($response->is_error());
my @content = split("\n",$response->content);
&Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60);
@@ -8518,6 +9559,12 @@ sub get_dns {
}
return $domain{$name}{$what};
}
+
+ sub domain_info {
+ &load_domain_tab() if (!$loaded);
+ return %domain;
+ }
+
}
@@ -8535,13 +9582,22 @@ sub get_dns {
next if ($configline =~ /^(\#|\s*$ )/x);
next if ($configline =~ /^\^/);
chomp($configline);
- my ($id,$domain,$role,$name)=split(/:/,$configline);
+ my ($id,$domain,$role,$name,$protocol)=split(/:/,$configline);
$name=~s/\s//g;
if ($id && $domain && $role && $name) {
$hostname{$id}=$name;
push(@{$name_to_host{$name}}, $id);
$hostdom{$id}=$domain;
if ($role eq 'library') { $libserv{$id}=$name; }
+ if (defined($protocol)) {
+ if ($protocol eq 'https') {
+ $protocol{$id} = $protocol;
+ } else {
+ $protocol{$id} = 'http';
+ }
+ } else {
+ $protocol{$id} = 'http';
+ }
}
}
}
@@ -8586,6 +9642,11 @@ sub get_dns {
return %name_to_host;
}
+ sub all_host_domain {
+ &load_hosts_tab() if (!$loaded);
+ return %hostdom;
+ }
+
sub is_library {
&load_hosts_tab() if (!$loaded);
@@ -8727,6 +9788,31 @@ sub get_dns {
return %iphost;
}
+
+ #
+ # Given a DNS returns the loncapa host name for that DNS
+ #
+ sub host_from_dns {
+ my ($dns) = @_;
+ my @hosts;
+ my $ip;
+
+ if (exists($name_to_ip{$dns})) {
+ $ip = $name_to_ip{$dns};
+ }
+ if (!$ip) {
+ $ip = gethostbyname($dns); # Initial translation to IP is in net order.
+ if (length($ip) == 4) {
+ $ip = &IO::Socket::inet_ntoa($ip);
+ }
+ }
+ if ($ip) {
+ @hosts = get_hosts_from_ip($ip);
+ return $hosts[0];
+ }
+ return undef;
+ }
+
}
BEGIN {
@@ -8984,7 +10070,7 @@ when the connection is brought back up
=item * B<con_failed>: unable to contact remote host and unable to save message
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
that was requested
@@ -9008,9 +10094,11 @@ in the user's environment.db and in %env
=item *
X<delenv()>
-B<delenv($regexp)>: removes all items from the session
-environment file that matches the regular expression in $regexp. The
-values are also delted from the current processes %env.
+B<delenv($delthis,$regexp)>: removes all items from the session
+environment file that begin with $delthis. If the
+optional second arg - $regexp - is true, $delthis is treated as a
+regular expression, otherwise \Q$delthis\E is used.
+The values are also deleted from the current processes %env.
=item * get_env_multiple($name)
@@ -9107,9 +10195,14 @@ and course level
=item *
-plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
-explanation of a user role term
-
+plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash
+(rolesplain.tab); plain text explanation of a user role term.
+$type is Course (default) or Community.
+If $forcedefault evaluates to true, text returned will be default
+text for $type. Otherwise, if this is a course, the text returned
+will be a custom name for the role (if defined in the course's
+environment). If no custom name is defined the default is returned.
+
=item *
get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) :
@@ -9151,9 +10244,16 @@ modifyuserauth($udom,$uname,$umode,$upas
=item *
-modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,
- $forceid,$desiredhome,$email,$inststatus) :
-modify user
+modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last, $gene,
+ $forceid,$desiredhome,$email,$inststatus,$candelete) :
+
+will update user information (firstname,middlename,lastname,generation,
+permanentemail), and if forceid is true, student/employee ID also.
+A user's institutional affiliation(s) can also be updated.
+User information fields will not be overwritten with empty entries
+unless the field is included in the $candelete array reference.
+This array is included when a single user is modified via "Manage Users",
+or when Autoupdate.pl is run by cron in a domain.
=item *
@@ -9314,7 +10414,11 @@ database) for a course
=item *
-createcourse($udom,$description,$url) : make/modify course
+createcourse($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner,$crstype,$cnum) : make course
+
+=item *
+
+generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community).
=back
@@ -9564,7 +10668,7 @@ Returns:
'key_exists: <key>' -> failed to anything out of $storehash, as at
least <key> already existed in the db (other
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
'refused' -> action was not allowed by remote machine
@@ -9618,8 +10722,15 @@ dirlist($uri) : return directory list ba
spareserver() : find server with least workload from spare.tab
+
+=item *
+
+host_from_dns($dns) : Returns the loncapa hostname corresponding to a DNS name or undef
+if there is no corresponding loncapa host.
+
=back
+
=head2 Apache Request
=over 4