--- loncom/lonnet/perl/lonnet.pm 2009/01/02 22:45:43 1.982
+++ loncom/lonnet/perl/lonnet.pm 2010/03/08 14:28:50 1.1053
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.982 2009/01/02 22:45:43 raeburn Exp $
+# $Id: lonnet.pm,v 1.1053 2010/03/08 14:28:50 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -75,7 +75,6 @@ use LWP::UserAgent();
use HTTP::Date;
use Image::Magick;
-# use Date::Parse;
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
$_64bit %env %protocol);
@@ -93,14 +92,13 @@ 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;
my $readit;
my $max_connection_retries = 10; # Or some such value.
-my $upload_photo_form = 0; #Variable to check when user upload a photo 0=not 1=true
-
require Exporter;
our @ISA = qw (Exporter);
@@ -150,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;
@@ -181,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 {
@@ -512,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);
@@ -525,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=~/^\Q$delthis\E/) {
- 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);
}
@@ -670,7 +717,12 @@ sub spareserver {
if ($protocol{$spare_server} eq 'https') {
$protocol = $protocol{$spare_server};
}
- $spare_server = $protocol.'://'.&hostname($spare_server);
+ if (defined($spare_server)) {
+ my $hostname = &hostname($spare_server);
+ if (defined($hostname)) {
+ $spare_server = $protocol.'://'.$hostname;
+ }
+ }
}
return $spare_server;
}
@@ -731,7 +783,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 ".
@@ -756,6 +809,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;
}
@@ -905,7 +961,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)=@_;
@@ -979,30 +1049,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);
}
@@ -1239,13 +1350,15 @@ sub get_domain_defaults {
}
my %domdefaults;
my %domconfig =
- &Apache::lonnet::get_dom('configuration',['defaults','quotas'],$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'}
+ $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
} else {
$domdefaults{'lang_def'} = &domain($domain,'lang_def');
$domdefaults{'auth_def'} = &domain($domain,'auth_def');
@@ -1264,6 +1377,21 @@ sub get_domain_defaults {
}
}
}
+ 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;
@@ -1594,12 +1722,17 @@ sub userenvironment {
}
$items=~s/\&$//;
my %returnhash=();
- my @answer=split(/\&/,
- &reply('get:'.$udom.':'.$unam.':environment:'.$items,
- &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;
}
@@ -1795,6 +1928,8 @@ sub ssi_body {
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;
@@ -1838,7 +1973,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);
}
@@ -1936,9 +2071,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,
@@ -2015,13 +2154,42 @@ sub clean_filename {
$fname=~s/\.(\d+)(?=\.)/_$1/g;
return $fname;
}
-
-#Wrapper function for userphotoupload
-sub userphotoupload
-{
- my($formname,$subdir) = @_;
- $upload_photo_form = 1;
- return &userfileupload($formname,undef,$subdir);
+# 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
@@ -2037,14 +2205,15 @@ sub userphotoupload
# $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);
@@ -2082,16 +2251,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,
@@ -2103,7 +2276,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'};
@@ -2114,15 +2288,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|/|) {
@@ -2137,6 +2313,7 @@ sub finishuserfileupload {
mkdir($filepath,0777);
}
}
+
# Save the file
{
if (!open(FH,'>'.$filepath.'/'.$file)) {
@@ -2150,32 +2327,24 @@ sub finishuserfileupload {
return '/adm/notfound.html';
}
close(FH);
- if($upload_photo_form==1)
- {
- my $ima = Image::Magick->new;
- $ima->Read($filepath.'/'.$file);
- if($ima->Get('width') > 300)
- {
- my $factor = $ima->Get('width')/300;
- $ima->Scale( width=>300, height=>$ima->Get('height')/$factor );
- }
- if($ima->Get('height') > 400)
- {
- my $factor = $ima->Get('height')/400;
- $ima->Scale( width=>$ima->Get('width')/$factor, height=>400);
- }
-
-
- $ima->Write($filepath.'/'.$file);
- $upload_photo_form = 0;
+ 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+$/)) {
@@ -2190,7 +2359,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) {
@@ -2322,21 +2491,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,
@@ -2479,7 +2648,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).
@@ -2584,7 +2753,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}
@@ -2593,7 +2762,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;
@@ -2614,7 +2784,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;
@@ -2634,6 +2805,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;
@@ -2643,6 +2817,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 !~ /:/) {
@@ -2655,15 +2830,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; }
@@ -2673,7 +2862,7 @@ sub get_course_adv_roles {
$returnhash{$role}=$username.':'.$domain;
}
} else {
- my $key=&plaintext($role);
+ my $key=&plaintext($role,$crstype);
if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; }
if ($returnhash{$key}) {
$returnhash{$key}.=','.$username.':'.$domain;
@@ -2708,6 +2897,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') {
@@ -2756,9 +2946,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) {
@@ -2844,7 +3057,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=''; }
@@ -2863,7 +3077,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);
@@ -2878,7 +3095,7 @@ sub courseiddump {
for (my $i=0; $i<@responses; $i++) {
$returnhash{$key}{$items[$i]} = &unescape($responses[$i]);
}
- }
+ }
}
}
}
@@ -2918,10 +3135,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;
@@ -3328,7 +3545,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});
}
@@ -3611,7 +3828,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)) {
@@ -3639,13 +3859,15 @@ sub privileged {
sub rolesinit {
my ($domain,$username,$authhost)=@_;
- my %userroles;
+ 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 \%userroles; }
+ if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||
+ ($rolesdump =~ /^error:/)) {
+ return \%userroles;
+ }
my %allroles=();
my %allgroups=();
- my $now=time;
- %userroles = ('user.login.time' => $now);
my $group_privs;
if ($rolesdump ne '') {
@@ -3711,6 +3933,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;
}
@@ -3764,7 +3989,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;
@@ -3807,6 +4032,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 {
@@ -3842,11 +4155,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);
}
@@ -4407,13 +4720,24 @@ sub is_portfolio_file {
}
sub usertools_access {
- my ($uname,$udom,$tool,$action) = @_;
- my $access;
- my %tools = (
- aboutme => 1,
- blog => 1,
- portfolio => 1,
- );
+ 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))) {
@@ -4423,18 +4747,23 @@ sub usertools_access {
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
if ($action ne 'reload') {
- return $env{'environment.availabletools.'.$tool};
- }
+ 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'})) {
- $toolstatus = $env{'environment.tools.'.$tool};
+ 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,'tools.'.$tool);
- $toolstatus = $userenv{'tools.'.$tool};
+ my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');
+ $toolstatus = $userenv{$context.'.'.$tool};
$inststatus = $userenv{'inststatus'};
}
@@ -4490,11 +4819,36 @@ sub usertools_access {
}
}
} else {
- $access = 1;
+ 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);
@@ -4530,6 +4884,55 @@ sub is_advanced_user {
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
sub customaccess {
@@ -4684,17 +5087,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
@@ -4704,7 +5158,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
@@ -4844,7 +5300,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;
@@ -5135,7 +5591,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/%%$//;
@@ -5268,11 +5724,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;
}
@@ -5291,6 +5757,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);
@@ -5405,6 +5888,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));
}
@@ -5462,7 +5952,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) = @_;
@@ -5615,28 +6179,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
@@ -5649,10 +6223,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\//) {
@@ -5678,9 +6269,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'});
@@ -5727,10 +6357,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 '') {
+ unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {
+ my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);
+ if ($result eq 'valid') {
+ my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);
+ if (($end == 0) || ($end > $now)) {
+ 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
@@ -5845,7 +6562,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);
@@ -5867,7 +6598,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';
@@ -5876,7 +6607,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
@@ -5990,48 +6721,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');
@@ -6061,6 +6834,41 @@ ENDINITMAP
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,
@@ -6071,6 +6879,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 {
@@ -7560,6 +8401,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 {
@@ -7626,7 +8472,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,
@@ -7663,6 +8509,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};
@@ -7671,6 +8520,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) {
@@ -8547,7 +9399,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;
}
@@ -8559,8 +9413,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+)$/);
@@ -8964,6 +9818,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 {
@@ -9245,9 +10124,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)
@@ -9344,9 +10225,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) :
@@ -9551,7 +10437,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
@@ -9855,8 +10745,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