--- loncom/lonnet/perl/lonnet.pm 2006/05/01 06:17:32 1.733
+++ loncom/lonnet/perl/lonnet.pm 2006/06/02 21:32:30 1.743
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.733 2006/05/01 06:17:32 raeburn Exp $
+# $Id: lonnet.pm,v 1.743 2006/06/02 21:32:30 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -38,7 +38,7 @@ use vars
qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom
%libserv %pr %prp $memcache %packagetab
%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount
- %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf
+ %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
%domaindescription %domain_auth_def %domain_auth_arg_def
%domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary
$tmpdir $_64bit %env);
@@ -52,6 +52,9 @@ use Storable qw(lock_store lock_nstore l
use Time::HiRes qw( gettimeofday tv_interval );
use Cache::Memcached;
use Digest::MD5;
+use lib '/home/httpd/lib/perl';
+use LONCAPA;
+use LONCAPA::Configuration;
my $readit;
my $max_connection_retries = 10; # Or some such value.
@@ -1384,7 +1387,22 @@ sub userfileupload {
open(my $fh,'>'.$fullpath.'/'.$fname);
print $fh $env{'form.'.$formname};
close($fh);
- return $fullpath.'/'.$fname;
+ return $fullpath.'/'.$fname;
+ } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { #files uploaded to create course page are handled differently
+ my $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.
+ '_'.$env{'user.domain'}.'/pending';
+ my @parts=split(/\//,$filepath);
+ my $fullpath = $perlvar{'lonDaemons'};
+ for (my $i=0;$i<@parts;$i++) {
+ $fullpath .= '/'.$parts[$i];
+ if ((-e $fullpath)!=1) {
+ mkdir($fullpath,0777);
+ }
+ }
+ open(my $fh,'>'.$fullpath.'/'.$fname);
+ print $fh $env{'form.'.$formname};
+ close($fh);
+ return $fullpath.'/'.$fname;
}
# Create the directory if not present
@@ -1648,11 +1666,11 @@ sub flushcourselogs {
if ($courseidbuffer{$coursehombuf{$crsid}}) {
$courseidbuffer{$coursehombuf{$crsid}}.='&'.
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
- ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid});
+ ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
} else {
$courseidbuffer{$coursehombuf{$crsid}}=
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
- ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid});
+ ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
}
}
#
@@ -1755,6 +1773,8 @@ sub courselog {
$env{'course.'.$env{'request.course.id'}.'.internal.coursecode'};
$courseownerbuf{$env{'request.course.id'}}=
$env{'course.'.$env{'request.course.id'}.'.internal.courseowner'};
+ $coursetypebuf{$env{'request.course.id'}}=
+ $env{'course.'.$env{'request.course.id'}.'.type'};
if (defined $courselogs{$env{'request.course.id'}}) {
$courselogs{$env{'request.course.id'}}.='&'.$what;
} else {
@@ -1925,7 +1945,7 @@ sub courseidput {
}
sub courseiddump {
- my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref)=@_;
+ my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter)=@_;
my %returnhash=();
unless ($domfilter) { $domfilter=''; }
foreach my $tryserver (keys %libserv) {
@@ -1934,7 +1954,7 @@ sub courseiddump {
foreach (
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
$sincefilter.':'.&escape($descfilter).':'.
- &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter),
+ &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter),
$tryserver))) {
my ($key,$value)=split(/\=/,$_);
if (($key) && ($value)) {
@@ -1952,8 +1972,8 @@ sub courseiddump {
sub dcmailput {
my ($domain,$msgid,$message,$server)=@_;
my $status = &Apache::lonnet::critical(
- 'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='.
- &Apache::lonnet::escape($message),$server);
+ 'dcmailput:'.$domain.':'.&escape($msgid).'='.
+ &escape($message),$server);
return $status;
}
@@ -2637,6 +2657,9 @@ sub coursedescription {
$returnhash{'home'}= $chome;
$returnhash{'domain'} = $cdomain;
$returnhash{'num'} = $cnum;
+ if (!defined($returnhash{'type'})) {
+ $returnhash{'type'} = 'Course';
+ }
while (my ($name,$value) = each %returnhash) {
$envhash{'course.'.$normalid.'.'.$name}=$value;
}
@@ -2693,7 +2716,7 @@ sub rolesinit {
my %allroles=();
my %allgroups=();
my $now=time;
- my $userroles="user.login.time=$now\n";
+ my %userroles = ('user.login.time' => $now);
my $group_privs;
if ($rolesdump ne '') {
@@ -2716,7 +2739,9 @@ sub rolesinit {
} else {
($trole,$tend,$tstart)=split(/_/,$role);
}
- $userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username);
+ my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
+ $username);
+ @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
if (($tend!=0) && ($tend<$now)) { $trole=''; }
if (($tstart!=0) && ($tstart>$now)) { $trole=''; }
if (($area ne '') && ($trole ne '')) {
@@ -2732,19 +2757,19 @@ sub rolesinit {
}
}
}
- my ($author,$adv) = &set_userprivs(\$userroles,\%allroles,\%allgroups);
- $userroles.='user.adv='.$adv."\n".
- 'user.author='.$author."\n";
+ my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups);
+ $userroles{'user.adv'} = $adv;
+ $userroles{'user.author'} = $author;
$env{'user.adv'}=$adv;
}
- return $userroles;
+ return \%userroles;
}
sub set_arearole {
my ($trole,$area,$tstart,$tend,$domain,$username) = @_;
# log the associated role with the area
&userrolelog($trole,$username,$domain,$area,$tstart,$tend);
- return 'user.role.'.$trole.'.'.$area.'='.$tstart.'.'.$tend."\n";
+ return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);
}
sub custom_roleprivs {
@@ -2846,7 +2871,7 @@ sub set_userprivs {
}
my $thesestr='';
foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }
- $$userroles.='user.priv.'.$_.'='.$thesestr."\n";
+ $userroles->{'user.priv.'.$_} = $thesestr;
}
return ($author,$adv);
}
@@ -3982,7 +4007,6 @@ sub modify_group_roles {
if ($result eq 'ok') {
&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
}
-
return $result;
}
@@ -4024,7 +4048,7 @@ sub get_users_groups {
my $hashid="$udom:$uname:$courseid";
my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
if (defined($cached)) {
- @usersgroups = split/:/,$grouplist;
+ @usersgroups = split(/:/,$grouplist);
} else {
$grouplist = '';
my %roleshash = &dump('roles',$udom,$uname,$courseid);
@@ -4035,7 +4059,7 @@ sub get_users_groups {
my $access_end = $env{'course.'.$courseid.
'.default_enrollment_end_date'};
my $now = time;
- foreach my $key (keys %roleshash) {
+ foreach my $key (keys(%roleshash)) {
if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
my $group = $1;
if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
@@ -4075,8 +4099,25 @@ sub devalidate_getgroups_cache {
# ------------------------------------------------------------------ Plain Text
sub plaintext {
- my $short=shift;
- return &Apache::lonlocal::mt($prp{$short});
+ my ($short,$type,$cid) = @_;
+ 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',
+ );
+ if (defined($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'});
+ }
}
# ----------------------------------------------------------------- Assign Role
@@ -4125,6 +4166,8 @@ sub assignrole {
$command.='_0_'.$start;
}
}
+ my $origstart = $start;
+ my $origend = $end;
# actually delete
if ($deleteflag) {
if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
@@ -4142,6 +4185,11 @@ sub assignrole {
# log new user role if status is ok
if ($answer eq 'ok') {
&userrolelog($role,$uname,$udom,$url,$start,$end);
+# for course roles, perform group memberships changes triggered by role change.
+ unless ($role =~ /^gr/) {
+ &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
+ $origstart);
+ }
}
return $answer;
}
@@ -4398,7 +4446,8 @@ sub writecoursepref {
# ---------------------------------------------------------- Make/modify course
sub createcourse {
- my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner)=@_;
+ my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
+ $course_owner,$crstype)=@_;
$url=&declutter($url);
my $cid='';
unless (&allowed('ccc',$udom)) {
@@ -4435,7 +4484,8 @@ sub createcourse {
# ----------------------------------------------------------------- Course made
# log existence
&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
- ':'.&escape($inst_code).':'.&escape($course_owner),$uhome);
+ ':'.&escape($inst_code).':'.&escape($course_owner).':'.
+ &escape($crstype),$uhome);
&flushcourselogs();
# set toplevel url
my $topurl=$url;
@@ -4818,7 +4868,7 @@ sub stat_file {
($udom,$uname,$file) =
($uri =~ m-/(?:uploaded|editupload)/?([^/]*)/?([^/]*)/?(.*)-);
$file = 'userfiles/'.$file;
- $dir = &Apache::loncommon::propath($udom,$uname);
+ $dir = &propath($udom,$uname);
}
if ($uri =~ m-^/res/-) {
($udom,$uname) =
@@ -5171,7 +5221,7 @@ sub EXT {
# ----------------------------------------------------- Cascading lookup scheme
my $symbp=$symbparm;
- my $mapp=(&decode_symb($symbp))[0];
+ my $mapp=&deversion((&decode_symb($symbp))[0]);
my $symbparm=$symbp.'.'.$spacequalifierrest;
my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
@@ -5319,9 +5369,29 @@ sub sort_course_groups { # Sort groups b
sub packages_tab_default {
my ($uri,$varname)=@_;
my (undef,$part,$name)=split(/\./,$varname);
- my $packages=&metadata($uri,'packages');
- foreach my $package (split(/,/,$packages)) {
+
+ my (@extension,@specifics,$do_default);
+ foreach my $package (split(/,/,&metadata($uri,'packages'))) {
my ($pack_type,$pack_part)=split(/_/,$package,2);
+ if ($pack_type eq 'default') {
+ $do_default=1;
+ } elsif ($pack_type eq 'extension') {
+ push(@extension,[$package,$pack_type,$pack_part]);
+ } else {
+ push(@specifics,[$package,$pack_type,$pack_part]);
+ }
+ }
+ # first look for a package that matches the requested part id
+ foreach my $package (@specifics) {
+ my (undef,$pack_type,$pack_part)=@{$package};
+ next if ($pack_part ne $part);
+ if (defined($packagetab{"$pack_type&$name&default"})) {
+ return $packagetab{"$pack_type&$name&default"};
+ }
+ }
+ # look for any possible matching non extension_ package
+ foreach my $package (@specifics) {
+ my (undef,$pack_type,$pack_part)=@{$package};
if (defined($packagetab{"$pack_type&$name&default"})) {
return $packagetab{"$pack_type&$name&default"};
}
@@ -5330,6 +5400,20 @@ sub packages_tab_default {
return $packagetab{$pack_type."_".$pack_part."&$name&default"};
}
}
+ # look for any posible extension_ match
+ foreach my $package (@extension) {
+ my ($package,$pack_type)=@{$package};
+ if (defined($packagetab{"$pack_type&$name&default"})) {
+ return $packagetab{"$pack_type&$name&default"};
+ }
+ if (defined($packagetab{$package."&$name&default"})) {
+ return $packagetab{$package."&$name&default"};
+ }
+ }
+ # look for a global default setting
+ if ($do_default && defined($packagetab{"default&$name&default"})) {
+ return $packagetab{"default&$name&default"};
+ }
return undef;
}
@@ -5415,16 +5499,16 @@ sub metadata {
} else {
$metaentry{':packages'}=$package.$keyroot;
}
- foreach (sort keys %packagetab) {
+ foreach my $pack_entry (keys(%packagetab)) {
my $part=$keyroot;
$part=~s/^\_//;
- if ($_=~/^\Q$package\E\&/ ||
- $_=~/^\Q$package\E_0\&/) {
- my ($pack,$name,$subp)=split(/\&/,$_);
+ if ($pack_entry=~/^\Q$package\E\&/ ||
+ $pack_entry=~/^\Q$package\E_0\&/) {
+ my ($pack,$name,$subp)=split(/\&/,$pack_entry);
# ignore package.tab specified default values
# here &package_tab_default() will fetch those
if ($subp eq 'default') { next; }
- my $value=$packagetab{$_};
+ my $value=$packagetab{$pack_entry};
my $unikey;
if ($pack =~ /_0$/) {
$unikey='parameter_0_'.$name;
@@ -5472,11 +5556,12 @@ sub metadata {
my $dir=$filename;
$dir=~s|[^/]*$||;
$location=&filelocation($dir,$location);
- foreach (sort(split(/\,/,&metadata($uri,'keys',
- $location,$unikey,
- $depthcount+1)))) {
- $metaentry{':'.$_}=$metaentry{':'.$_};
- $metathesekeys{$_}=1;
+ my $metadata =
+ &metadata($uri,'keys', $location,$unikey,
+ $depthcount+1);
+ foreach my $meta (split(',',$metadata)) {
+ $metaentry{':'.$meta}=$metaentry{':'.$meta};
+ $metathesekeys{$meta}=1;
}
}
} else {
@@ -5485,8 +5570,9 @@ sub metadata {
$unikey.='_'.$token->[2]->{'name'};
}
$metathesekeys{$unikey}=1;
- foreach (@{$token->[3]}) {
- $metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_};
+ foreach my $param (@{$token->[3]}) {
+ $metaentry{':'.$unikey.'.'.$param} =
+ $token->[2]->{$param};
}
my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
my $default=$metaentry{':'.$unikey.'.default'};
@@ -5507,14 +5593,14 @@ sub metadata {
}
}
my ($extension) = ($uri =~ /\.(\w+)$/);
- foreach my $key (sort(keys(%packagetab))) {
+ foreach my $key (keys(%packagetab)) {
#no specific packages #how's our extension
if ($key!~/^extension_\Q$extension\E&/) { next; }
&metadata_create_package_def($uri,$key,'extension_'.$extension,
\%metathesekeys);
}
if (!exists($metaentry{':packages'})) {
- foreach my $key (sort(keys(%packagetab))) {
+ foreach my $key (keys(%packagetab)) {
#no specific packages well let's get default then
if ($key!~/^default&/) { next; }
&metadata_create_package_def($uri,$key,'default',
@@ -5532,15 +5618,22 @@ sub metadata {
my $dir=$filename;
$dir=~s|[^/]*$||;
$location=&filelocation($dir,$location);
- foreach (sort(split(/\,/,&metadata($uri,'keys',
- $location,'_rights',
- $depthcount+1)))) {
- #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_};
- $metathesekeys{$_}=1;
+ my $rights_metadata =
+ &metadata($uri,'keys',$location,'_rights',
+ $depthcount+1);
+ foreach my $rights (split(',',$rights_metadata)) {
+ #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
+ $metathesekeys{$rights}=1;
}
}
}
- $metaentry{':keys'}=join(',',keys %metathesekeys);
+ # uniqifiy package listing
+ my %seen;
+ my @uniq_packages =
+ grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
+ $metaentry{':packages'} = join(',',@uniq_packages);
+
+ $metaentry{':keys'} = join(',',keys(%metathesekeys));
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
&do_cache_new('meta',$uri,\%metaentry,60*60);
@@ -5576,7 +5669,7 @@ sub metadata_create_package_def {
sub metadata_generate_part0 {
my ($metadata,$metacache,$uri) = @_;
my %allnames;
- foreach my $metakey (sort keys %$metadata) {
+ foreach my $metakey (keys(%$metadata)) {
if ($metakey=~/^parameter\_(.*)/) {
my $part=$$metacache{':'.$metakey.'.part'};
my $name=$$metacache{':'.$metakey.'.name'};
@@ -6411,7 +6504,7 @@ sub filelocation {
my @ids=¤t_machine_ids();
foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
if ($is_me) {
- $location=&Apache::loncommon::propath($udom,$uname).
+ $location=&propath($udom,$uname).
'/userfiles/'.$filename;
} else {
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
@@ -6532,21 +6625,6 @@ sub freeze_escape {
return &escape($value);
}
-# -------------------------------------------------------- Escape Special Chars
-
-sub escape {
- my $str=shift;
- $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
- return $str;
-}
-
-# ----------------------------------------------------- Un-Escape Special Chars
-
-sub unescape {
- my $str=shift;
- $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
- return $str;
-}
sub thaw_unescape {
my ($value)=@_;
@@ -6720,8 +6798,14 @@ sub get_iphost {
while (my $configline=<$config>) {
chomp($configline);
if ($configline) {
- my ($short,$plain)=split(/:/,$configline);
- if ($plain ne '') { $prp{$short}=$plain; }
+ my ($short,@plain)=split(/:/,$configline);
+ %{$prp{$short}} = ();
+ if (@plain > 0) {
+ $prp{$short}{'std'} = $plain[0];
+ for (my $i=1; $i<@plain; $i++) {
+ $prp{$short}{'alt'.$i} = $plain[$i];
+ }
+ }
}
}
close($config);