--- loncom/lonnet/perl/lonnet.pm 2006/05/18 01:08:54 1.739
+++ loncom/lonnet/perl/lonnet.pm 2006/06/07 21:15:10 1.746
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.739 2006/05/18 01:08:54 raeburn Exp $
+# $Id: lonnet.pm,v 1.746 2006/06/07 21:15:10 raeburn 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);
}
@@ -4074,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
@@ -4404,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)) {
@@ -4441,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;
@@ -4511,9 +4555,15 @@ sub is_locked {
$env{'user.domain'},$env{'user.name'});
my ($tmp)=keys(%locked);
if ($tmp=~/^error:/) { undef(%locked); }
-
+
if (ref($locked{$file_name}) eq 'ARRAY') {
- $is_locked = 'true';
+ $is_locked = 'false';
+ foreach my $entry (@{$locked{$file_name}}) {
+ if (ref($entry) eq 'ARRAY') {
+ $is_locked = 'true';
+ last;
+ }
+ }
} else {
$is_locked = 'false';
}
@@ -4602,48 +4652,113 @@ sub files_not_in_path {
return (@return_files);
}
-#--------------------------------------------------------------Get Marked as Read Only
+#----------------------------------------------Get portfolio file permissions
-
-sub get_marked_as_readonly {
- my ($domain,$user,$what) = @_;
+sub get_portfile_permissions {
+ # returns a reference to a hash containing contents of file_permissions.db
+ my ($domain,$user) = @_;
my %current_permissions = &dump('file_permissions',$domain,$user);
my ($tmp)=keys(%current_permissions);
if ($tmp=~/^error:/) { undef(%current_permissions); }
+ return \%current_permissions;
+}
+
+#---------------------------------------------Get portfolio file access controls
+
+sub get_access_controls {
+ # returns a hash containing access control information retrieved from
+ # file_permissions.db. The hash contains key=value pairs where key is
+ # the control type, end date and start date, in the form type_end_start
+ # and value is a string containing access control settings (in XML),
+ #
+ # Internally access_controls are stored in file_permissions.db in an
+ # array of arrays and a hash, where arrays are locks set when a portfolio
+ # file has been uploaded to an essayresponse problem in a course, and
+ # the hash contains other data. Two keys are currently defined in the hash:
+ # access and accesscount. The value for accesscount is a scalar - equal to
+ # the next number to use as the first part of an access control key
+ # when defining a new control. The value for access is an anonymous hash
+ # where keys are access controls and values are settings.
+ #
+ my ($current_permissions,$group,$file) = @_;
+ my @access_checks = ();
+ my %access;
+ if (defined($file)) {
+ @access_checks = ($file);
+ } else {
+ @access_checks = keys(%{$current_permissions});
+ }
+ foreach my $file_name (@access_checks) {
+ my $value = $$current_permissions{$file_name};
+ if (defined($group)) {
+ if ($file_name !~ m-^\Q$group\E/-) {
+ next;
+ }
+ }
+ if (ref($value) eq "ARRAY") {
+ foreach my $stored_what (@{$value}) {
+ if (ref($stored_what) eq 'HASH') {
+ $access{$file_name} = $$stored_what{'access'};
+ }
+ }
+ }
+ }
+ return %access;
+}
+
+#------------------------------------------------------Get Marked as Read Only
+
+sub get_marked_as_readonly {
+ my ($domain,$user,$what,$group) = @_;
+ my $current_permissions = &get_portfile_permissions($domain,$user);
my @readonly_files;
my $cmp1=$what;
if (ref($what)) { $cmp1=join('',@{$what}) };
- while (my ($file_name,$value) = each(%current_permissions)) {
+ while (my ($file_name,$value) = each(%{$current_permissions})) {
+ if (defined($group)) {
+ if ($file_name !~ m-^\Q$group\E/-) {
+ next;
+ }
+ }
if (ref($value) eq "ARRAY"){
foreach my $stored_what (@{$value}) {
my $cmp2=$stored_what;
- if (ref($stored_what)) { $cmp2=join('',@{$stored_what}) };
+ if (ref($stored_what eq 'HASH')) {
+ next;
+ } elsif (ref($stored_what eq 'ARRAY')) {
+ $cmp2=join('',@{$stored_what});
+ }
if ($cmp1 eq $cmp2) {
push(@readonly_files, $file_name);
+ last;
} elsif (!defined($what)) {
push(@readonly_files, $file_name);
+ last;
}
}
- }
+ }
}
return @readonly_files;
}
#-----------------------------------------------------------Get Marked as Read Only Hash
sub get_marked_as_readonly_hash {
- my ($domain,$user,$what) = @_;
- my %current_permissions = &dump('file_permissions',$domain,$user);
- my ($tmp)=keys(%current_permissions);
- if ($tmp=~/^error:/) { undef(%current_permissions); }
-
+ my ($current_permissions,$group,$what) = @_;
my %readonly_files;
- while (my ($file_name,$value) = each(%current_permissions)) {
+ while (my ($file_name,$value) = each(%{$current_permissions})) {
+ if (defined($group)) {
+ if ($file_name !~ m-^\Q$group\E/-) {
+ next;
+ }
+ }
if (ref($value) eq "ARRAY"){
foreach my $stored_what (@{$value}) {
- if ($stored_what eq $what) {
- $readonly_files{$file_name} = 'locked';
- } elsif (!defined($what)) {
- $readonly_files{$file_name} = 'locked';
+ if (ref($stored_what) eq 'ARRAY') {
+ if ($stored_what eq $what) {
+ $readonly_files{$file_name} = 'locked';
+ } elsif (!defined($what)) {
+ $readonly_files{$file_name} = 'locked';
+ }
}
}
}
@@ -4655,13 +4770,13 @@ sub get_marked_as_readonly_hash {
sub unmark_as_readonly {
# unmarks $file_name (if $file_name is defined), or all files locked by $what
# for portfolio submissions, $what contains [$symb,$crsid]
- my ($domain,$user,$what,$file_name) = @_;
+ my ($domain,$user,$what,$file_name,$group) = @_;
my $symb_crs = $what;
if (ref($what)) { $symb_crs=join('',@$what); }
- my %current_permissions = &dump('file_permissions',$domain,$user);
+ my %current_permissions = &dump('file_permissions',$domain,$user,$group);
my ($tmp)=keys(%current_permissions);
if ($tmp=~/^error:/) { undef(%current_permissions); }
- my @readonly_files = &get_marked_as_readonly($domain,$user,$what);
+ my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group);
foreach my $file (@readonly_files) {
if (defined($file_name) && ($file_name ne $file)) { next; }
my $current_locks = $current_permissions{$file};
@@ -4670,9 +4785,13 @@ sub unmark_as_readonly {
if (ref($current_locks) eq "ARRAY"){
foreach my $locker (@{$current_locks}) {
my $compare=$locker;
- if (ref($locker)) { $compare=join('',@{$locker}) };
- if ($compare ne $symb_crs) {
- push(@new_locks, $locker);
+ if (!ref($locker) eq 'ARRAY') {
+ push(@new_locks,$locker);
+ } else {
+ $compare=join('',@{$locker});
+ if ($compare ne $symb_crs) {
+ push(@new_locks, $locker);
+ }
}
}
if (scalar(@new_locks) > 0) {
@@ -4824,7 +4943,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) =
@@ -5073,8 +5192,14 @@ sub EXT {
if ( (defined($Apache::lonhomework::parsing_a_problem)
|| defined($Apache::lonhomework::parsing_a_task))
&&
- ($symbparm eq &symbread()) ) {
- return $Apache::lonhomework::history{$qualifierrest};
+ ($symbparm eq &symbread()) ) {
+ # if we are in the middle of processing the resource the
+ # get the value we are planning on committing
+ if (defined($Apache::lonhomework::results{$qualifierrest})) {
+ return $Apache::lonhomework::results{$qualifierrest};
+ } else {
+ return $Apache::lonhomework::history{$qualifierrest};
+ }
} else {
my %restored;
if ($publicuser || $env{'request.state'} eq 'construct') {
@@ -6460,7 +6585,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/'.
@@ -6581,21 +6706,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)=@_;
@@ -6769,8 +6879,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);