--- loncom/lonnet/perl/lonnet.pm 2006/01/13 19:22:29 1.683.2.12
+++ loncom/lonnet/perl/lonnet.pm 2007/02/16 01:04:19 1.832
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.683.2.12 2006/01/13 19:22:29 albertel Exp $
+# $Id: lonnet.pm,v 1.832 2007/02/16 01:04:19 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -38,14 +38,13 @@ 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);
use IO::Socket;
use GDBM_File;
-use Apache::Constants qw(:common :http);
use HTML::LCParser;
use HTML::Parser;
use Fcntl qw(:flock);
@@ -53,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 Math::Random;
+use LONCAPA qw(:DEFAULT :match);
+use LONCAPA::Configuration;
my $readit;
my $max_connection_retries = 10; # Or some such value.
@@ -86,6 +88,29 @@ delayed.
# --------------------------------------------------------------------- Logging
+{
+ my $logid;
+ sub instructor_log {
+ my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;
+ $logid++;
+ my $id=time().'00000'.$$.'00000'.$logid;
+ return &Apache::lonnet::put('nohist_'.$hash_name,
+ { $id => {
+ 'exe_uname' => $env{'user.name'},
+ 'exe_udom' => $env{'user.domain'},
+ 'exe_time' => time(),
+ 'exe_ip' => $ENV{'REMOTE_ADDR'},
+ 'delflag' => $delflag,
+ 'logentry' => $storehash,
+ 'uname' => $uname,
+ 'udom' => $udom,
+ }
+ },
+ $env{'course.'.$env{'request.course.id'}.'.domain'},
+ $env{'course.'.$env{'request.course.id'}.'.num'}
+ );
+ }
+}
sub logtouch {
my $execdir=$perlvar{'lonDaemons'};
@@ -124,7 +149,7 @@ sub logperm {
# -------------------------------------------------- Non-critical communication
sub subreply {
my ($cmd,$server)=@_;
- my $peerfile="$perlvar{'lonSockDir'}/$server";
+ my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
#
# With loncnew process trimming, there's a timing hole between lonc server
# process exit and the master server picking up the listen on the AF_UNIX
@@ -152,7 +177,7 @@ sub subreply {
}
my $answer;
if ($client) {
- print $client "$cmd\n";
+ print $client "sethost:$server:$cmd\n";
$answer=<$client>;
if (!$answer) { $answer="con_lost"; }
chomp($answer);
@@ -256,9 +281,18 @@ sub critical {
return $answer;
}
-# ------------------------------------------- Transfer profile into environment
+# ------------------------------------------- check if return value is an error
-sub transfer_profile_to_env {
+sub error {
+ my ($result) = @_;
+ if ($result =~ /^(con_lost|no_such_host|error: (\d+) (.*))/) {
+ if ($2 == 2) { return undef; }
+ return $1;
+ }
+ return undef;
+}
+
+sub convert_and_load_session_env {
my ($lonidsdir,$handle)=@_;
my @profile;
{
@@ -267,132 +301,157 @@ sub transfer_profile_to_env {
@profile=<$idf>;
close($idf);
}
- my $envi;
- my %Remove;
- for ($envi=0;$envi<=$#profile;$envi++) {
- chomp($profile[$envi]);
- my ($envname,$envvalue)=split(/=/,$profile[$envi],2);
- $env{$envname} = $envvalue;
+ my %temp_env;
+ foreach my $line (@profile) {
+ if ($line !~ m/=/) {
+ return 0;
+ }
+ chomp($line);
+ my ($envname,$envvalue)=split(/=/,$line,2);
+ $temp_env{&unescape($envname)} = &unescape($envvalue);
+ }
+ unlink("$lonidsdir/$handle.id");
+ if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(),
+ 0640)) {
+ %disk_env = %temp_env;
+ @env{keys(%temp_env)} = @disk_env{keys(%temp_env)};
+ untie(%disk_env);
+ }
+ return 1;
+}
+
+# ------------------------------------------- Transfer profile into environment
+my $env_loaded;
+sub transfer_profile_to_env {
+ my ($lonidsdir,$handle,$force_transfer) = @_;
+ if (!$force_transfer && $env_loaded) { return; }
+
+ if (!defined($lonidsdir)) {
+ $lonidsdir = $perlvar{'lonIDsDir'};
+ }
+ if (!defined($handle)) {
+ ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
+ }
+
+ my $convert;
+ {
+ open(my $idf,"$lonidsdir/$handle.id");
+ flock($idf,LOCK_SH);
+ if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
+ &GDBM_READER(),0640)) {
+ @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
+ untie(%disk_env);
+ } else {
+ $convert = 1;
+ }
+ }
+ if ($convert) {
+ if (!&convert_and_load_session_env($lonidsdir,$handle)) {
+ &logthis("Failed to load session, or convert session.");
+ }
+ }
+
+ my %remove;
+ while ( my $envname = each(%env) ) {
if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
if ($time < time-300) {
- $Remove{$key}++;
+ $remove{$key}++;
}
}
}
+
$env{'user.environment'} = "$lonidsdir/$handle.id";
- foreach my $expired_key (keys(%Remove)) {
+ $env_loaded=1;
+ foreach my $expired_key (keys(%remove)) {
&delenv($expired_key);
}
}
+sub timed_flock {
+ my ($file,$lock_type) = @_;
+ my $failed=0;
+ eval {
+ local $SIG{__DIE__}='DEFAULT';
+ local $SIG{ALRM}=sub {
+ $failed=1;
+ die("failed lock");
+ };
+ alarm(13);
+ flock($file,$lock_type);
+ alarm(0);
+ };
+ if ($failed) {
+ return undef;
+ } else {
+ return 1;
+ }
+}
+
# ---------------------------------------------------------- Append Environment
sub appenv {
my %newenv=@_;
- foreach (keys %newenv) {
- if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
+ foreach my $key (keys(%newenv)) {
+ if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) {
&logthis("WARNING: ".
- "Attempt to modify environment ".$_." to ".$newenv{$_}
+ "Attempt to modify environment ".$key." to ".$newenv{$key}
.'');
- delete($newenv{$_});
+ delete($newenv{$key});
} else {
- $env{$_}=$newenv{$_};
- }
- }
-
- my $lockfh;
- unless (open($lockfh,"$env{'user.environment'}")) {
- return 'error: '.$!;
- }
- unless (flock($lockfh,LOCK_EX)) {
- &logthis("WARNING: ".
- 'Could not obtain exclusive lock in appenv: '.$!);
- close($lockfh);
- return 'error: '.$!;
- }
-
- my @oldenv;
- {
- my $fh;
- unless (open($fh,"$env{'user.environment'}")) {
- return 'error: '.$!;
- }
- @oldenv=<$fh>;
- close($fh);
- }
- for (my $i=0; $i<=$#oldenv; $i++) {
- chomp($oldenv[$i]);
- if ($oldenv[$i] ne '') {
- my ($name,$value)=split(/=/,$oldenv[$i],2);
- unless (defined($newenv{$name})) {
- $newenv{$name}=$value;
- }
+ $env{$key}=$newenv{$key};
}
}
- {
- my $fh;
- unless (open($fh,">$env{'user.environment'}")) {
- return 'error';
- }
- my $newname;
- foreach $newname (keys %newenv) {
- print $fh "$newname=$newenv{$newname}\n";
+ open(my $env_file,$env{'user.environment'});
+ if (&timed_flock($env_file,LOCK_EX)
+ &&
+ tie(my %disk_env,'GDBM_File',$env{'user.environment'},
+ (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
+ while (my ($key,$value) = each(%newenv)) {
+ $disk_env{$key} = $value;
}
- close($fh);
+ untie(%disk_env);
}
-
- close($lockfh);
return 'ok';
}
# ----------------------------------------------------- Delete from Environment
sub delenv {
my $delthis=shift;
- my %newenv=();
if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
&logthis("WARNING: ".
"Attempt to delete from environment ".$delthis);
return 'error';
}
- my @oldenv;
- {
- my $fh;
- unless (open($fh,"$env{'user.environment'}")) {
- return 'error';
- }
- unless (flock($fh,LOCK_SH)) {
- &logthis("WARNING: ".
- 'Could not obtain shared lock in delenv: '.$!);
- close($fh);
- return 'error: '.$!;
- }
- @oldenv=<$fh>;
- close($fh);
- }
- {
- my $fh;
- unless (open($fh,">$env{'user.environment'}")) {
- return 'error';
- }
- unless (flock($fh,LOCK_EX)) {
- &logthis("WARNING: ".
- 'Could not obtain exclusive lock in delenv: '.$!);
- close($fh);
- return 'error: '.$!;
- }
- foreach (@oldenv) {
- if ($_=~/^$delthis/) {
- my ($key,undef) = split('=',$_,2);
+ open(my $env_file,$env{'user.environment'});
+ if (&timed_flock($env_file,LOCK_EX)
+ &&
+ tie(my %disk_env,'GDBM_File',$env{'user.environment'},
+ (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
+ foreach my $key (keys(%disk_env)) {
+ if ($key=~/^$delthis/) {
delete($env{$key});
- } else {
- print $fh $_;
+ delete($disk_env{$key});
}
}
- close($fh);
+ untie(%disk_env);
}
return 'ok';
}
+sub get_env_multiple {
+ my ($name) = @_;
+ my @values;
+ if (defined($env{$name})) {
+ # exists is it an array
+ if (ref($env{$name})) {
+ @values=@{ $env{$name} };
+ } else {
+ $values[0]=$env{$name};
+ }
+ }
+ return(@values);
+}
+
# ------------------------------------------ Find out current server userload
# there is a copy in lond
sub userload {
@@ -445,48 +504,67 @@ sub overloaderror {
sub spareserver {
my ($loadpercent,$userloadpercent,$want_server_name) = @_;
- my $tryserver;
- my $spareserver='';
+ my $spare_server;
if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
- my $lowestserver=$loadpercent > $userloadpercent?
- $loadpercent : $userloadpercent;
- foreach $tryserver (keys(%spareid)) {
- my $loadans=&reply('load',$tryserver);
- my $userloadans=&reply('userload',$tryserver);
- if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
- next; #didn't get a number from the server
- }
- my $answer;
- if ($loadans =~ /\d/) {
- if ($userloadans =~ /\d/) {
- #both are numbers, pick the bigger one
- $answer=$loadans > $userloadans?
- $loadans : $userloadans;
- } else {
- $answer = $loadans;
- }
- } else {
- $answer = $userloadans;
- }
- if (($answer =~ /\d/) && ($answer<$lowestserver)) {
- if ($want_server_name) {
- $spareserver=$tryserver;
- } else {
- $spareserver="http://$hostname{$tryserver}";
- }
- $lowestserver=$answer;
+ my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent
+ : $userloadpercent;
+
+ foreach my $try_server (@{ $spareid{'primary'} }) {
+ ($spare_server, $lowest_load) =
+ &compare_server_load($try_server, $spare_server, $lowest_load);
+ }
+
+ my $found_server = ($spare_server ne '' && $lowest_load < 100);
+
+ if (!$found_server) {
+ foreach my $try_server (@{ $spareid{'default'} }) {
+ ($spare_server, $lowest_load) =
+ &compare_server_load($try_server, $spare_server, $lowest_load);
}
}
- return $spareserver;
+
+ if (!$want_server_name) {
+ $spare_server="http://$hostname{$spare_server}";
+ }
+ return $spare_server;
}
+sub compare_server_load {
+ my ($try_server, $spare_server, $lowest_load) = @_;
+
+ my $loadans = &reply('load', $try_server);
+ my $userloadans = &reply('userload',$try_server);
+
+ if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
+ next; #didn't get a number from the server
+ }
+
+ my $load;
+ if ($loadans =~ /\d/) {
+ if ($userloadans =~ /\d/) {
+ #both are numbers, pick the bigger one
+ $load = ($loadans > $userloadans) ? $loadans
+ : $userloadans;
+ } else {
+ $load = $loadans;
+ }
+ } else {
+ $load = $userloadans;
+ }
+
+ if (($load =~ /\d/) && ($load < $lowest_load)) {
+ $spare_server = $try_server;
+ $lowest_load = $load;
+ }
+ return ($spare_server,$lowest_load);
+}
# --------------------------------------------- Try to change a user's password
sub changepass {
- my ($uname,$udom,$currentpass,$newpass,$server)=@_;
+ my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
$currentpass = &escape($currentpass);
$newpass = &escape($newpass);
- my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass",
+ my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context",
$server);
if (! $answer) {
&logthis("No reply on password change request to $server ".
@@ -535,8 +613,8 @@ sub queryauthenticate {
sub authenticate {
my ($uname,$upass,$udom)=@_;
- $upass=escape($upass);
- $uname=~s/\W//g;
+ $upass=&escape($upass);
+ $uname= &LONCAPA::clean_username($uname);
my $uhome=&homeserver($uname,$udom);
if (!$uhome) {
&logthis("User $uname at $udom is unknown in authenticate");
@@ -611,8 +689,8 @@ sub idget {
sub idrget {
my ($udom,@unames)=@_;
my %returnhash=();
- foreach (@unames) {
- $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1];
+ foreach my $uname (@unames) {
+ $returnhash{$uname}=(&userenvironment($udom,$uname,'id'))[1];
}
return %returnhash;
}
@@ -622,22 +700,69 @@ sub idrget {
sub idput {
my ($udom,%ids)=@_;
my %servers=();
- foreach (keys %ids) {
- &cput('environment',{'id'=>$ids{$_}},$udom,$_);
- my $uhom=&homeserver($_,$udom);
+ foreach my $uname (keys(%ids)) {
+ &cput('environment',{'id'=>$ids{$uname}},$udom,$uname);
+ my $uhom=&homeserver($uname,$udom);
if ($uhom ne 'no_host') {
- my $id=&escape($ids{$_});
+ my $id=&escape($ids{$uname});
$id=~tr/A-Z/a-z/;
- my $unam=&escape($_);
+ my $esc_unam=&escape($uname);
if ($servers{$uhom}) {
- $servers{$uhom}.='&'.$id.'='.$unam;
+ $servers{$uhom}.='&'.$id.'='.$esc_unam;
} else {
- $servers{$uhom}=$id.'='.$unam;
+ $servers{$uhom}=$id.'='.$esc_unam;
}
}
}
- foreach (keys %servers) {
- &critical('idput:'.$udom.':'.$servers{$_},$_);
+ foreach my $server (keys(%servers)) {
+ &critical('idput:'.$udom.':'.$servers{$server},$server);
+ }
+}
+
+# ------------------------------------------- get items from domain db files
+
+sub get_dom {
+ my ($namespace,$storearr,$udom)=@_;
+ my $items='';
+ foreach my $item (@$storearr) {
+ $items.=&escape($item).'&';
+ }
+ $items=~s/\&$//;
+ if (!$udom) { $udom=$env{'user.domain'}; }
+ if (exists($domain_primary{$udom})) {
+ my $uhome=$domain_primary{$udom};
+ my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
+ my @pairs=split(/\&/,$rep);
+ if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
+ return @pairs;
+ }
+ my %returnhash=();
+ my $i=0;
+ foreach my $item (@$storearr) {
+ $returnhash{$item}=&thaw_unescape($pairs[$i]);
+ $i++;
+ }
+ return %returnhash;
+ } else {
+ &logthis("get_dom failed - no primary domain server for $udom");
+ }
+}
+
+# -------------------------------------------- put items in domain db files
+
+sub put_dom {
+ my ($namespace,$storehash,$udom)=@_;
+ if (!$udom) { $udom=$env{'user.domain'}; }
+ if (exists($domain_primary{$udom})) {
+ my $uhome=$domain_primary{$udom};
+ my $items='';
+ foreach my $item (keys(%$storehash)) {
+ $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
+ }
+ $items=~s/\&$//;
+ return &reply("putdom:$udom:$namespace:$items",$uhome);
+ } else {
+ &logthis("put_dom failed - no primary domain server for $udom");
}
}
@@ -774,17 +899,32 @@ sub validate_access_key {
# ------------------------------------- Find the section of student in a course
sub devalidate_getsection_cache {
my ($udom,$unam,$courseid)=@_;
- $courseid=~s/\_/\//g;
- $courseid=~s/^(\w)/\/$1/;
my $hashid="$udom:$unam:$courseid";
&devalidate_cache_new('getsection',$hashid);
}
+sub courseid_to_courseurl {
+ my ($courseid) = @_;
+ #already url style courseid
+ return $courseid if ($courseid =~ m{^/});
+
+ if (exists($env{'course.'.$courseid.'.num'})) {
+ my $cnum = $env{'course.'.$courseid.'.num'};
+ my $cdom = $env{'course.'.$courseid.'.domain'};
+ return "/$cdom/$cnum";
+ }
+
+ my %courseinfo=&Apache::lonnet::coursedescription($courseid);
+ if (exists($courseinfo{'num'})) {
+ return "/$courseinfo{'domain'}/$courseinfo{'num'}";
+ }
+
+ return undef;
+}
+
sub getsection {
my ($udom,$unam,$courseid)=@_;
my $cachetime=1800;
- $courseid=~s/\_/\//g;
- $courseid=~s/^(\w)/\/$1/;
my $hashid="$udom:$unam:$courseid";
my ($result,$cached)=&is_cached_new('getsection',$hashid);
@@ -805,14 +945,13 @@ sub getsection {
# If there is more than one expired role, choose the one which ended last.
# If there is a role which has expired, return it.
#
- foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
- &homeserver($unam,$udom)))) {
- my ($key,$value)=split(/\=/,$_);
- $key=&unescape($key);
+ $courseid = &courseid_to_courseurl($courseid);
+ my %roleshash = &dump('roles',$udom,$unam,$courseid);
+ foreach my $key (keys(%roleshash)) {
next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
my $section=$1;
if ($key eq $courseid.'_st') { $section=''; }
- my ($dummy,$end,$start)=split(/\_/,&unescape($value));
+ my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key}));
my $now=time;
if (defined($end) && $end && ($now > $end)) {
$Expired{$end}=$section;
@@ -840,11 +979,10 @@ sub getsection {
}
sub save_cache {
- my ($r)=@_;
- if (! $r->is_initial_req()) { return DECLINED; }
&purge_remembered();
+ #&Apache::loncommon::validate_page();
undef(%env);
- return OK;
+ undef($env_loaded);
}
my $to_remember=-1;
@@ -947,25 +1085,62 @@ sub userenvironment {
sub studentphoto {
my ($udom,$unam,$ext) = @_;
my $home=&Apache::lonnet::homeserver($unam,$udom);
- my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext",$home);
- my $url="/uploaded/$udom/$unam/internal/studentphoto.".$ext;
- if ($ret ne 'ok') {
- return '/adm/lonKaputt/lonlogo_broken.gif';
+ if (defined($env{'request.course.id'})) {
+ if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {
+ if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
+ return(&retrievestudentphoto($udom,$unam,$ext));
+ } else {
+ my ($result,$perm_reqd)=
+ &Apache::lonnet::auto_photo_permission($unam,$udom);
+ if ($result eq 'ok') {
+ if (!($perm_reqd eq 'yes')) {
+ return(&retrievestudentphoto($udom,$unam,$ext));
+ }
+ }
+ }
+ }
+ } else {
+ my ($result,$perm_reqd) =
+ &Apache::lonnet::auto_photo_permission($unam,$udom);
+ if ($result eq 'ok') {
+ if (!($perm_reqd eq 'yes')) {
+ return(&retrievestudentphoto($udom,$unam,$ext));
+ }
+ }
+ }
+ return '/adm/lonKaputt/lonlogo_broken.gif';
+}
+
+sub retrievestudentphoto {
+ my ($udom,$unam,$ext,$type) = @_;
+ my $home=&Apache::lonnet::homeserver($unam,$udom);
+ my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home);
+ if ($ret eq 'ok') {
+ my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";
+ if ($type eq 'thumbnail') {
+ $url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext";
+ }
+ my $tokenurl=&Apache::lonnet::tokenwrapper($url);
+ return $tokenurl;
+ } else {
+ if ($type eq 'thumbnail') {
+ return '/adm/lonKaputt/genericstudent_tn.gif';
+ } else {
+ return '/adm/lonKaputt/lonlogo_broken.gif';
+ }
}
- my $tokenurl=&Apache::lonnet::tokenwrapper($url);
- return $tokenurl;
}
# -------------------------------------------------------------------- New chat
sub chatsend {
- my ($newentry,$anon)=@_;
+ my ($newentry,$anon,$group)=@_;
my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'};
my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
my $chome=$env{'course.'.$env{'request.course.id'}.'.home'};
&reply('chatsend:'.$cdom.':'.$cnum.':'.
&escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'.
- &escape($newentry)),$chome);
+ &escape($newentry)).':'.$group,$chome);
}
# ------------------------------------------ Find current version of a resource
@@ -1027,6 +1202,7 @@ sub repcopy {
}
$filename=~s/[\n\r]//g;
my $transname="$filename.in.transfer";
+# FIXME: this should flock
if ((-e $filename) || (-e $transname)) { return 'ok'; }
my $remoteurl=subscribe($filename);
if ($remoteurl =~ /^con_lost by/) {
@@ -1093,7 +1269,7 @@ sub ssi_body {
}
my $output=($filelink=~/^http\:/?&externalssi($filelink):
&ssi($filelink,%form));
- $output=~s|//(\s*)?\s||gs;
+ $output=~s|//(\s*)?\s||gs;
$output=~s/^.*?\]*\>//si;
$output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
return $output;
@@ -1101,6 +1277,15 @@ sub ssi_body {
# --------------------------------------------------------- Server Side Include
+sub absolute_url {
+ my ($host_name) = @_;
+ my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
+ if ($host_name eq '') {
+ $host_name = $ENV{'SERVER_NAME'};
+ }
+ return $protocol.$host_name;
+}
+
sub ssi {
my ($fn,%form)=@_;
@@ -1108,12 +1293,14 @@ sub ssi {
my $ua=new LWP::UserAgent;
my $request;
-
+
+ $form{'no_update_last_known'}=1;
+
if (%form) {
- $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);
+ $request=new HTTP::Request('POST',&absolute_url().$fn);
$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
} else {
- $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);
+ $request=new HTTP::Request('GET',&absolute_url().$fn);
}
$request->header(Cookie => $ENV{'HTTP_COOKIE'});
@@ -1264,15 +1451,17 @@ sub store_edited_file {
}
sub clean_filename {
- my ($fname)=@_;
+ my ($fname,$args)=@_;
# Replace Windows backslashes by forward slashes
$fname=~s/\\/\//g;
-# Get rid of everything but the actual filename
- $fname=~s/^.*\/([^\/]+)$/$1/;
+ if (!$args->{'keep_path'}) {
+ # Get rid of everything but the actual filename
+ $fname=~s/^.*\/([^\/]+)$/$1/;
+ }
# Replace spaces by underscores
$fname=~s/\s+/\_/g;
# Replace all other weird characters by nothing
- $fname=~s/[^\w\.\-]//g;
+ $fname=~s{[^/\w\.\-]}{}g;
# Replace all .\d. sequences with _\d. so they no longer look like version
# numbers
$fname=~s/\.(\d+)(?=\.)/_$1/g;
@@ -1280,12 +1469,19 @@ sub clean_filename {
}
# --------------- Take an uploaded file and put it into the userfiles directory
-# input: name of form element, coursedoc=1 means this is for the course
-# output: url of file in userspace
+# input: $formname - the contents of the file are in $env{"form.$formname"}
+# the desired filenam is in $env{"form.$formname.filename"}
+# $coursedoc - if true up to the current course
+# if false
+# $subdir - directory in userfile to store the file into
+# $parser, $allfiles, $codebase - unknown
+#
+# output: url of file in userspace, or error:
+# or /adm/notfound.html if failure to upload occurse
sub userfileupload {
- my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase)=@_;
+ my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_;
if (!defined($subdir)) { $subdir='unknown'; }
my $fname=$env{'form.'.$formname.'.filename'};
$fname=&clean_filename($fname);
@@ -1306,8 +1502,24 @@ 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
$fname="$subdir/$fname";
if ($coursedoc) {
@@ -1323,9 +1535,19 @@ sub userfileupload {
$fname,$formname,$parser,
$allfiles,$codebase);
}
+ } elsif (defined($destuname)) {
+ my $docuname=$destuname;
+ my $docudom=$destudom;
+ return &finishuserfileupload($docuname,$docudom,$formname,
+ $fname,$parser,$allfiles,$codebase);
+
} else {
my $docuname=$env{'user.name'};
my $docudom=$env{'user.domain'};
+ if (exists($env{'form.group'})) {
+ $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
+ $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
+ }
return &finishuserfileupload($docuname,$docudom,$formname,
$fname,$parser,$allfiles,$codebase);
}
@@ -1351,8 +1573,16 @@ sub finishuserfileupload {
}
# Save the file
{
- open(FH,'>'.$filepath.'/'.$file);
- print FH $env{'form.'.$formname};
+ if (!open(FH,'>'.$filepath.'/'.$file)) {
+ &logthis('Failed to create '.$filepath.'/'.$file);
+ print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
+ return '/adm/notfound.html';
+ }
+ if (!print FH ($env{'form.'.$formname})) {
+ &logthis('Failed to write to '.$filepath.'/'.$file);
+ print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
+ return '/adm/notfound.html';
+ }
close(FH);
}
if ($parser eq 'parse') {
@@ -1495,7 +1725,20 @@ sub removeuploadedurl {
sub removeuserfile {
my ($docuname,$docudom,$fname)=@_;
my $home=&homeserver($docuname,$docudom);
- return &reply("removeuserfile:$docudom/$docuname/$fname",$home);
+ my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
+ 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 $sqlresult =
+ &update_portfolio_table($docuname,$docudom,$file,
+ 'portfolio_metadata',$group,
+ 'delete');
+ }
+ }
+ return $result;
}
sub mkdiruserfile {
@@ -1507,8 +1750,23 @@ sub mkdiruserfile {
sub renameuserfile {
my ($docuname,$docudom,$old,$new)=@_;
my $home=&homeserver($docuname,$docudom);
- return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'.
- &escape("$new"),$home);
+ my $result = &reply("renameuserfile:$docudom:$docuname:".
+ &escape("$old").':'.&escape("$new"),$home);
+ if ($result eq 'ok') {
+ if (($old !~ /\.meta$/) && (&is_portfolio_file($old))) {
+ my $oldmeta = $old.'.meta';
+ my $newmeta = $new.'.meta';
+ my $metaresult =
+ &renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
+ my $url = "/uploaded/$docudom/$docuname/$old";
+ my ($file,$group) = (&parse_portfolio_url($url))[3,4];
+ my $sqlresult =
+ &update_portfolio_table($docuname,$docudom,$file,
+ 'portfolio_metadata',$group,
+ 'delete');
+ }
+ }
+ return $result;
}
# ------------------------------------------------------------------------- Log
@@ -1534,8 +1792,7 @@ sub flushcourselogs {
# times and course titles for all courseids
#
my %courseidbuffer=();
- foreach (keys %courselogs) {
- my $crsid=$_;
+ foreach my $crsid (keys %courselogs) {
if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
&escape($courselogs{$crsid}),
$coursehombuf{$crsid}) eq 'ok') {
@@ -1551,19 +1808,19 @@ 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});
}
}
#
# Write course id database (reverse lookup) to homeserver of courses
# Is used in pickcourse
#
- foreach (keys %courseidbuffer) {
- &courseidput($hostdom{$_},$courseidbuffer{$_},$_);
+ foreach my $crsid (keys(%courseidbuffer)) {
+ &courseidput($hostdom{$crsid},$courseidbuffer{$crsid},$crsid);
}
#
# File accesses
@@ -1572,7 +1829,8 @@ sub flushcourselogs {
foreach my $entry (keys(%accesshash)) {
if ($entry =~ /___count$/) {
my ($dom,$name);
- ($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:);
+ ($dom,$name,undef)=
+ ($entry=~m{___($match_domain)/($match_name)/(.*)___count$});
if (! defined($dom) || $dom eq '' ||
! defined($name) || $name eq '') {
my $cid = $env{'request.course.id'};
@@ -1593,7 +1851,7 @@ sub flushcourselogs {
}
}
} else {
- my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);
+ my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});
my %temphash=($entry => $accesshash{$entry});
if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
delete $accesshash{$entry};
@@ -1604,8 +1862,7 @@ sub flushcourselogs {
# Roles
# Reverse lookup of user roles for course faculty/staff and co-authorship
#
- foreach (keys %userrolehash) {
- my $entry=$_;
+ foreach my $entry (keys(%userrolehash)) {
my ($role,$uname,$udom,$runame,$rudom,$rsec)=
split(/\:/,$entry);
if (&Apache::lonnet::put('nohist_userroles',
@@ -1658,6 +1915,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 {
@@ -1675,9 +1934,9 @@ sub courseacclog {
if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) {
$what.=':POST';
# FIXME: Probably ought to escape things....
- foreach (keys %env) {
- if ($_=~/^form\.(.*)/) {
- $what.=':'.$1.'='.$env{$_};
+ foreach my $key (keys(%env)) {
+ if ($key=~/^form\.(.*)/) {
+ $what.=':'.$1.'='.$env{$key};
}
}
} elsif ($fnsymb =~ m:^/adm/searchcat:) {
@@ -1739,27 +1998,24 @@ sub get_course_adv_roles {
$cid=$env{'request.course.id'} unless (defined($cid));
my %coursehash=&coursedescription($cid);
my %nothide=();
- foreach (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
- $nothide{join(':',split(/[\@\:]/,$_))}=1;
+ foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
+ $nothide{join(':',split(/[\@\:]/,$user))}=1;
}
my %returnhash=();
my %dumphash=
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
my $now=time;
- foreach (keys %dumphash) {
- my ($tend,$tstart)=split(/\:/,$dumphash{$_});
+ 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(/\:/,$_);
+ my ($role,$username,$domain,$section)=split(/\:/,$entry);
if ($username eq '' || $domain eq '') { next; }
if ((&privileged($username,$domain)) &&
(!$nothide{$username.':'.$domain})) { next; }
if ($role eq 'cr') { next; }
my $key=&plaintext($role);
- if ($role =~ /^cr/) {
- $key=(split('/',$role))[3];
- }
if ($section) { $key.=' (Sec/Grp '.$section.')'; }
if ($returnhash{$key}) {
$returnhash{$key}.=','.$username.':'.$domain;
@@ -1771,21 +2027,45 @@ sub get_course_adv_roles {
}
sub get_my_roles {
- my ($uname,$udom)=@_;
+ my ($uname,$udom,$types,$roles,$roledoms)=@_;
unless (defined($uname)) { $uname=$env{'user.name'}; }
unless (defined($udom)) { $udom=$env{'user.domain'}; }
my %dumphash=
&dump('nohist_userroles',$udom,$uname);
my %returnhash=();
my $now=time;
- foreach (keys %dumphash) {
- my ($tend,$tstart)=split(/\:/,$dumphash{$_});
+ 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(/\:/,$_);
+ my $status = 'active';
+ if (($tend) && ($tend<$now)) {
+ $status = 'previous';
+ }
+ if (($tstart) && ($now<$tstart)) {
+ $status = 'future';
+ }
+ if (ref($types) eq 'ARRAY') {
+ if (!grep(/^\Q$status\E$/,@{$types})) {
+ next;
+ }
+ } else {
+ if ($status ne 'active') {
+ next;
+ }
+ }
+ my ($role,$username,$domain,$section)=split(/\:/,$entry);
+ if (ref($roledoms) eq 'ARRAY') {
+ if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
+ next;
+ }
+ }
+ if (ref($roles) eq 'ARRAY') {
+ if (!grep(/^\Q$role\E$/,@{$roles})) {
+ next;
+ }
+ }
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
- }
+ }
return %returnhash;
}
@@ -1804,7 +2084,7 @@ sub getannounce {
if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {
my $announcement='';
- while (<$fh>) { $announcement .=$_; }
+ while (my $line = <$fh>) { $announcement .= $line; }
close($fh);
if ($announcement=~/\w/) {
return
@@ -1828,18 +2108,18 @@ sub courseidput {
}
sub courseiddump {
- my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref)=@_;
+ my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
my %returnhash=();
unless ($domfilter) { $domfilter=''; }
foreach my $tryserver (keys %libserv) {
if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) {
if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {
- foreach (
+ foreach my $line (
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
$sincefilter.':'.&escape($descfilter).':'.
- &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter),
+ &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),
$tryserver))) {
- my ($key,$value)=split(/\=/,$_);
+ my ($key,$value)=split(/\=/,$line,2);
if (($key) && ($value)) {
$returnhash{&unescape($key)}=$value;
}
@@ -1855,8 +2135,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;
}
@@ -1868,8 +2148,8 @@ sub dcmaildump {
&escape($enddate).':';
my @esc_senders=map { &escape($_)} @$senders;
$cmd.=&escape(join('&',@esc_senders));
- foreach (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {
- my ($key,$value) = split(/\=/,$_);
+ foreach my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {
+ my ($key,$value) = split(/\=/,$line,2);
if (($key) && ($value)) {
$returnhash{&unescape($key)} = &unescape($value);
}
@@ -1892,11 +2172,11 @@ sub get_domain_roles {
foreach my $tryserver (keys(%libserv)) {
if ($hostdom{$tryserver} eq $dom) {
%{$personnel{$tryserver}}=();
- foreach (
+ foreach my $line (
split(/\&/,&reply('domrolesdump:'.$dom.':'.
&escape($startdate).':'.&escape($enddate).':'.
&escape($rolelist), $tryserver))) {
- my($key,$value) = split(/\=/,$_);
+ my ($key,$value) = split(/\=/,$line,2);
if (($key) && ($value)) {
$personnel{$tryserver}{&unescape($key)} = &unescape($value);
}
@@ -1910,7 +2190,7 @@ sub get_domain_roles {
sub get_first_access {
my ($type,$argsymb)=@_;
- my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
+ my ($symb,$courseid,$udom,$uname)=&whichuser();
if ($argsymb) { $symb=$argsymb; }
my ($map,$id,$res)=&decode_symb($symb);
if ($type eq 'map') {
@@ -1924,7 +2204,7 @@ sub get_first_access {
sub set_first_access {
my ($type)=@_;
- my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
+ my ($symb,$courseid,$udom,$uname)=&whichuser();
my ($map,$id,$res)=&decode_symb($symb);
if ($type eq 'map') {
$res=&symbread($map);
@@ -2118,27 +2398,27 @@ sub hash2str {
sub hashref2str {
my ($hashref)=@_;
my $result='__HASH_REF__';
- foreach (sort(keys(%$hashref))) {
- if (ref($_) eq 'ARRAY') {
- $result.=&arrayref2str($_).'=';
- } elsif (ref($_) eq 'HASH') {
- $result.=&hashref2str($_).'=';
- } elsif (ref($_)) {
+ foreach my $key (sort(keys(%$hashref))) {
+ if (ref($key) eq 'ARRAY') {
+ $result.=&arrayref2str($key).'=';
+ } elsif (ref($key) eq 'HASH') {
+ $result.=&hashref2str($key).'=';
+ } elsif (ref($key)) {
$result.='=';
- #print("Got a ref of ".(ref($_))." skipping.");
+ #print("Got a ref of ".(ref($key))." skipping.");
} else {
- if ($_) {$result.=&escape($_).'=';} else { last; }
+ if ($key) {$result.=&escape($key).'=';} else { last; }
}
- if(ref($hashref->{$_}) eq 'ARRAY') {
- $result.=&arrayref2str($hashref->{$_}).'&';
- } elsif(ref($hashref->{$_}) eq 'HASH') {
- $result.=&hashref2str($hashref->{$_}).'&';
- } elsif(ref($hashref->{$_})) {
+ if(ref($hashref->{$key}) eq 'ARRAY') {
+ $result.=&arrayref2str($hashref->{$key}).'&';
+ } elsif(ref($hashref->{$key}) eq 'HASH') {
+ $result.=&hashref2str($hashref->{$key}).'&';
+ } elsif(ref($hashref->{$key})) {
$result.='&';
- #print("Got a ref of ".(ref($hashref->{$_}))." skipping.");
+ #print("Got a ref of ".(ref($hashref->{$key}))." skipping.");
} else {
- $result.=&escape($hashref->{$_}).'&';
+ $result.=&escape($hashref->{$key}).'&';
}
}
$result=~s/\&$//;
@@ -2418,8 +2698,8 @@ sub store {
$$storehash{'host'}=$perlvar{'lonHostID'};
my $namevalue='';
- foreach (keys %$storehash) {
- $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
+ foreach my $key (keys(%$storehash)) {
+ $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
}
$namevalue=~s/\&$//;
&courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
@@ -2454,8 +2734,8 @@ sub cstore {
$$storehash{'host'}=$perlvar{'lonHostID'};
my $namevalue='';
- foreach (keys %$storehash) {
- $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
+ foreach my $key (keys(%$storehash)) {
+ $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
}
$namevalue=~s/\&$//;
&courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
@@ -2487,14 +2767,14 @@ sub restore {
my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
my %returnhash=();
- foreach (split(/\&/,$answer)) {
- my ($name,$value)=split(/\=/,$_);
+ foreach my $line (split(/\&/,$answer)) {
+ my ($name,$value)=split(/\=/,$line);
$returnhash{&unescape($name)}=&thaw_unescape($value);
}
my $version;
for ($version=1;$version<=$returnhash{'version'};$version++) {
- foreach (split(/\:/,$returnhash{$version.':keys'})) {
- $returnhash{$_}=$returnhash{$version.':'.$_};
+ foreach my $item (split(/\:/,$returnhash{$version.':keys'})) {
+ $returnhash{$item}=$returnhash{$version.':'.$item};
}
}
return %returnhash;
@@ -2503,7 +2783,7 @@ sub restore {
# ---------------------------------------------------------- Course Description
sub coursedescription {
- my $courseid=shift;
+ my ($courseid,$args)=@_;
$courseid=~s/^\///;
$courseid=~s/\_/\//g;
my ($cdomain,$cnum)=split(/\//,$courseid);
@@ -2513,13 +2793,37 @@ sub coursedescription {
# trying and trying and trying to get the course description.
my %envhash=();
my %returnhash=();
- $envhash{'course.'.$normalid.'.last_cache'}=time;
+
+ my $expiretime=600;
+ if ($env{'request.course.id'} eq $normalid) {
+ $expiretime=120;
+ }
+
+ my $prefix='course.'.$cdomain.'_'.$cnum.'.';
+ if (!$args->{'freshen_cache'}
+ && ((time-$env{$prefix.'last_cache'}) < $expiretime) ) {
+ foreach my $key (keys(%env)) {
+ next if ($key !~ /^\Q$prefix\E(.*)/);
+ my ($setting) = $1;
+ $returnhash{$setting} = $env{$key};
+ }
+ return %returnhash;
+ }
+
+ # get the data agin
+ if (!$args->{'one_time'}) {
+ $envhash{'course.'.$normalid.'.last_cache'}=time;
+ }
+
if ($chome ne 'no_host') {
%returnhash=&dump('environment',$cdomain,$cnum);
if (!exists($returnhash{'con_lost'})) {
$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;
}
@@ -2531,7 +2835,9 @@ sub coursedescription {
$envhash{'course.'.$normalid.'.num'}=$cnum;
}
}
- &appenv(%envhash);
+ if (!$args->{'one_time'}) {
+ &appenv(%envhash);
+ }
return %returnhash;
}
@@ -2544,9 +2850,9 @@ sub privileged {
if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; }
my $now=time;
if ($rolesdump ne '') {
- foreach (split(/&/,$rolesdump)) {
- if ($_!~/^rolesdef_/) {
- my ($area,$role)=split(/=/,$_);
+ foreach my $entry (split(/&/,$rolesdump)) {
+ if ($entry!~/^rolesdef_/) {
+ my ($area,$role)=split(/=/,$entry);
$area=~s/\_\w\w$//;
my ($trole,$tend,$tstart)=split(/_/,$role);
if (($trole eq 'dc') || ($trole eq 'su')) {
@@ -2574,18 +2880,18 @@ 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 '') {
- foreach (split(/&/,$rolesdump)) {
- if ($_!~/^rolesdef_/) {
- my ($area,$role)=split(/=/,$_);
+ foreach my $entry (split(/&/,$rolesdump)) {
+ if ($entry!~/^rolesdef_/) {
+ my ($area,$role)=split(/=/,$entry);
$area=~s/\_\w\w$//;
my ($trole,$tend,$tstart,$group_privs);
if ($role=~/^cr/) {
- if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) {
- ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|);
+ if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
+ ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|);
($tend,$tstart)=split('_',$trest);
} else {
$trole=$role;
@@ -2597,7 +2903,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 '')) {
@@ -2613,19 +2921,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 {
@@ -2662,7 +2970,7 @@ sub group_roleprivs {
if (($tend!=0) && ($tend<$now)) { $access = 0; }
if (($tstart!=0) && ($tstart>$now)) { $access=0; }
if ($access) {
- my ($course,$group) = ($area =~ m|(/\w+/\w+)/([^/]+)$|);
+ my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|);
$$allgroups{$course}{$group} .=':'.$group_privs;
}
}
@@ -2693,7 +3001,7 @@ sub set_userprivs {
if (keys(%{$allgroups}) > 0) {
foreach my $role (keys %{$allroles}) {
my ($trole,$area,$sec,$extendedarea);
- if ($role =~ m|^(\w+)\.(/\w+/\w+)(/?\w*)|) {
+ if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) {
$trole = $1;
$area = $2;
$sec = $3;
@@ -2708,15 +3016,15 @@ sub set_userprivs {
}
}
}
- foreach (keys(%grouproles)) {
- $$allroles{$_} = $grouproles{$_};
+ foreach my $group (keys(%grouproles)) {
+ $$allroles{$group} = $grouproles{$group};
}
- foreach (keys %{$allroles}) {
- my %thesepriv=();
- if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
- foreach (split(/:/,$$allroles{$_})) {
- if ($_ ne '') {
- my ($privilege,$restrictions)=split(/&/,$_);
+ foreach my $role (keys(%{$allroles})) {
+ my %thesepriv;
+ if (($role=~/^au/) || ($role=~/^ca/)) { $author=1; }
+ foreach my $item (split(/:/,$$allroles{$role})) {
+ if ($item ne '') {
+ my ($privilege,$restrictions)=split(/&/,$item);
if ($restrictions eq '') {
$thesepriv{$privilege}='F';
} elsif ($thesepriv{$privilege} ne 'F') {
@@ -2726,8 +3034,10 @@ sub set_userprivs {
}
}
my $thesestr='';
- foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }
- $$userroles.='user.priv.'.$_.'='.$thesestr."\n";
+ foreach my $priv (keys(%thesepriv)) {
+ $thesestr.=':'.$priv.'&'.$thesepriv{$priv};
+ }
+ $userroles->{'user.priv.'.$role} = $thesestr;
}
return ($author,$adv);
}
@@ -2737,8 +3047,8 @@ sub set_userprivs {
sub get {
my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';
- foreach (@$storearr) {
- $items.=escape($_).'&';
+ foreach my $item (@$storearr) {
+ $items.=&escape($item).'&';
}
$items=~s/\&$//;
if (!$udomain) { $udomain=$env{'user.domain'}; }
@@ -2752,8 +3062,8 @@ sub get {
}
my %returnhash=();
my $i=0;
- foreach (@$storearr) {
- $returnhash{$_}=&thaw_unescape($pairs[$i]);
+ foreach my $item (@$storearr) {
+ $returnhash{$item}=&thaw_unescape($pairs[$i]);
$i++;
}
return %returnhash;
@@ -2764,8 +3074,8 @@ sub get {
sub del {
my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';
- foreach (@$storearr) {
- $items.=escape($_).'&';
+ foreach my $item (@$storearr) {
+ $items.=&escape($item).'&';
}
$items=~s/\&$//;
if (!$udomain) { $udomain=$env{'user.domain'}; }
@@ -2778,7 +3088,31 @@ sub del {
# -------------------------------------------------------------- dump interface
sub dump {
- my ($namespace,$udomain,$uname,$regexp)=@_;
+ my ($namespace,$udomain,$uname,$regexp,$range)=@_;
+ if (!$udomain) { $udomain=$env{'user.domain'}; }
+ if (!$uname) { $uname=$env{'user.name'}; }
+ my $uhome=&homeserver($uname,$udomain);
+ if ($regexp) {
+ $regexp=&escape($regexp);
+ } else {
+ $regexp='.';
+ }
+ my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
+ my @pairs=split(/\&/,$rep);
+ my %returnhash=();
+ foreach my $item (@pairs) {
+ my ($key,$value)=split(/=/,$item,2);
+ $key = &unescape($key);
+ next if ($key =~ /^error: 2 /);
+ $returnhash{$key}=&thaw_unescape($value);
+ }
+ return %returnhash;
+}
+
+# --------------------------------------------------------- dumpstore interface
+
+sub dumpstore {
+ my ($namespace,$udomain,$uname,$regexp,$range)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
@@ -2787,12 +3121,13 @@ sub dump {
} else {
$regexp='.';
}
- my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome);
+ my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
my @pairs=split(/\&/,$rep);
my %returnhash=();
- foreach (@pairs) {
- my ($key,$value)=split(/=/,$_);
- $returnhash{unescape($key)}=&thaw_unescape($value);
+ foreach my $item (@pairs) {
+ my ($key,$value)=split(/=/,$item,2);
+ next if ($key =~ /^error: 2 /);
+ $returnhash{$key}=&thaw_unescape($value);
}
return %returnhash;
}
@@ -2806,8 +3141,9 @@ sub getkeys {
my $uhome=&homeserver($uname,$udomain);
my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
my @keyarray=();
- foreach (split(/\&/,$rep)) {
- push (@keyarray,&unescape($_));
+ foreach my $key (split(/\&/,$rep)) {
+ next if ($key =~ /^error: 2 /);
+ push(@keyarray,&unescape($key));
}
return @keyarray;
}
@@ -2827,15 +3163,15 @@ sub currentdump {
if ($rep eq "unknown_cmd") {
# an old lond will not know currentdump
# Do a dump and make it look like a currentdump
- my @tmp = &dump($courseid,$sdom,$sname,'.');
+ my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
return if ($tmp[0] =~ /^(error:|no_such_host)/);
my %hash = @tmp;
@tmp=();
%returnhash = %{&convert_dump_to_currentdump(\%hash)};
} else {
my @pairs=split(/\&/,$rep);
- foreach (@pairs) {
- my ($key,$value)=split(/=/,$_);
+ foreach my $pair (@pairs) {
+ my ($key,$value)=split(/=/,$pair,2);
my ($symb,$param) = split(/:/,$key);
$returnhash{&unescape($symb)}->{&unescape($param)} =
&thaw_unescape($value);
@@ -2852,6 +3188,8 @@ sub convert_dump_to_currentdump{
# we might run in to problems with parameter names =~ /^v\./
while (my ($key,$value) = each(%hash)) {
my ($v,$symb,$param) = split(/:/,$key);
+ $symb = &unescape($symb);
+ $param = &unescape($param);
next if ($v eq 'version' || $symb eq 'keys');
next if (exists($returnhash{$symb}) &&
exists($returnhash{$symb}->{$param}) &&
@@ -2913,8 +3251,8 @@ sub put {
if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
my $items='';
- foreach (keys %$storehash) {
- $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
+ foreach my $item (keys(%$storehash)) {
+ $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}
$items=~s/\&$//;
return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
@@ -2938,25 +3276,53 @@ sub newput {
# --------------------------------------------------------- putstore interface
sub putstore {
- my ($namespace,$storehash,$udomain,$uname)=@_;
+ my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
my $items='';
- my %allitems = ();
- foreach (keys %$storehash) {
- if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
- my $key = $1.':keys:'.$2;
- $allitems{$key} .= $3.':';
- }
- $items.=$_.'='.&freeze_escape($$storehash{$_}).'&';
- }
- foreach (keys %allitems) {
- $allitems{$_} =~ s/\:$//;
- $items.= $_.'='.$allitems{$_}.'&';
+ foreach my $key (keys(%$storehash)) {
+ $items.= &escape($key).'='.&freeze_escape($storehash->{$key}).'&';
}
$items=~s/\&$//;
- return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
+ my $esc_symb=&escape($symb);
+ my $esc_v=&escape($version);
+ my $reply =
+ &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
+ $uhome);
+ if ($reply eq 'unknown_cmd') {
+ # gfall back to way things use to be done
+ return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
+ $uname);
+ }
+ return $reply;
+}
+
+sub old_putstore {
+ my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
+ if (!$udomain) { $udomain=$env{'user.domain'}; }
+ if (!$uname) { $uname=$env{'user.name'}; }
+ my $uhome=&homeserver($uname,$udomain);
+ my %newstorehash;
+ foreach my $item (keys(%$storehash)) {
+ my $key = $version.':'.&escape($symb).':'.$item;
+ $newstorehash{$key} = $storehash->{$item};
+ }
+ my $items='';
+ my %allitems = ();
+ foreach my $item (keys(%newstorehash)) {
+ if ($item =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
+ my $key = $1.':keys:'.$2;
+ $allitems{$key} .= $3.':';
+ }
+ $items.=$item.'='.&freeze_escape($newstorehash{$item}).'&';
+ }
+ foreach my $item (keys(%allitems)) {
+ $allitems{$item} =~ s/\:$//;
+ $items.= $item.'='.$allitems{$item}.'&';
+ }
+ $items=~s/\&$//;
+ return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
}
# ------------------------------------------------------ critical put interface
@@ -2967,8 +3333,8 @@ sub cput {
if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
my $items='';
- foreach (keys %$storehash) {
- $items.=escape($_).'='.&freeze_escape($$storehash{$_}).'&';
+ foreach my $item (keys(%$storehash)) {
+ $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}
$items=~s/\&$//;
return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
@@ -2979,8 +3345,8 @@ sub cput {
sub eget {
my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';
- foreach (@$storearr) {
- $items.=escape($_).'&';
+ foreach my $item (@$storearr) {
+ $items.=&escape($item).'&';
}
$items=~s/\&$//;
if (!$udomain) { $udomain=$env{'user.domain'}; }
@@ -2990,8 +3356,8 @@ sub eget {
my @pairs=split(/\&/,$rep);
my %returnhash=();
my $i=0;
- foreach (@$storearr) {
- $returnhash{$_}=&thaw_unescape($pairs[$i]);
+ foreach my $item (@$storearr) {
+ $returnhash{$item}=&thaw_unescape($pairs[$i]);
$i++;
}
return %returnhash;
@@ -2999,12 +3365,15 @@ sub eget {
# ------------------------------------------------------------ tmpput interface
sub tmpput {
- my ($storehash,$server)=@_;
+ my ($storehash,$server,$context)=@_;
my $items='';
- foreach (keys(%$storehash)) {
- $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
+ foreach my $item (keys(%$storehash)) {
+ $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}
$items=~s/\&$//;
+ if (defined($context)) {
+ $items .= ':'.&escape($context);
+ }
return &reply("tmpput:$items",$server);
}
@@ -3028,21 +3397,259 @@ sub tmpdel {
return &reply("tmpdel:$token",$server);
}
+# -------------------------------------------------- portfolio access checking
+
+sub portfolio_access {
+ my ($requrl) = @_;
+ my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
+ my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
+ if ($result) {
+ my %setters;
+ if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
+ my ($startblock,$endblock) =
+ &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);
+ if ($startblock && $endblock) {
+ return 'B';
+ }
+ } else {
+ my ($startblock,$endblock) =
+ &Apache::loncommon::blockcheck(\%setters,'port');
+ if ($startblock && $endblock) {
+ return 'B';
+ }
+ }
+ }
+ if ($result eq 'ok') {
+ return 'F';
+ } elsif ($result =~ /^[^:]+:guest_/) {
+ return 'A';
+ }
+ return '';
+}
+
+sub get_portfolio_access {
+ my ($udom,$unum,$file_name,$group,$access_hash) = @_;
+
+ if (!ref($access_hash)) {
+ my $current_perms = &get_portfile_permissions($udom,$unum);
+ my %access_controls = &get_access_controls($current_perms,$group,
+ $file_name);
+ $access_hash = $access_controls{$file_name};
+ }
+
+ my ($public,$guest,@domains,@users,@courses,@groups);
+ my $now = time;
+ if (ref($access_hash) eq 'HASH') {
+ foreach my $key (keys(%{$access_hash})) {
+ my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
+ if ($start > $now) {
+ next;
+ }
+ if ($end && $end<$now) {
+ next;
+ }
+ if ($scope eq 'public') {
+ $public = $key;
+ last;
+ } elsif ($scope eq 'guest') {
+ $guest = $key;
+ } elsif ($scope eq 'domains') {
+ push(@domains,$key);
+ } elsif ($scope eq 'users') {
+ push(@users,$key);
+ } elsif ($scope eq 'course') {
+ push(@courses,$key);
+ } elsif ($scope eq 'group') {
+ push(@groups,$key);
+ }
+ }
+ if ($public) {
+ return 'ok';
+ }
+ if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
+ if ($guest) {
+ return $guest;
+ }
+ } else {
+ if (@domains > 0) {
+ foreach my $domkey (@domains) {
+ if (ref($access_hash->{$domkey}{'dom'}) eq 'ARRAY') {
+ if (grep(/^\Q$env{'user.domain'}\E$/,@{$access_hash->{$domkey}{'dom'}})) {
+ return 'ok';
+ }
+ }
+ }
+ }
+ if (@users > 0) {
+ foreach my $userkey (@users) {
+ if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {
+ return 'ok';
+ }
+ }
+ }
+ my %roleshash;
+ my @courses_and_groups = @courses;
+ push(@courses_and_groups,@groups);
+ if (@courses_and_groups > 0) {
+ my (%allgroups,%allroles);
+ my ($start,$end,$role,$sec,$group);
+ foreach my $envkey (%env) {
+ if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
+ my $cid = $2.'_'.$3;
+ if ($1 eq 'gr') {
+ $group = $4;
+ $allgroups{$cid}{$group} = $env{$envkey};
+ } else {
+ if ($4 eq '') {
+ $sec = 'none';
+ } else {
+ $sec = $4;
+ }
+ $allroles{$cid}{$1}{$sec} = $env{$envkey};
+ }
+ } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_courseid)/?([^/]*)$-) {
+ my $cid = $2.'_'.$3;
+ if ($4 eq '') {
+ $sec = 'none';
+ } else {
+ $sec = $4;
+ }
+ $allroles{$cid}{$1}{$sec} = $env{$envkey};
+ }
+ }
+ if (keys(%allroles) == 0) {
+ return;
+ }
+ foreach my $key (@courses_and_groups) {
+ my %content = %{$$access_hash{$key}};
+ my $cnum = $content{'number'};
+ my $cdom = $content{'domain'};
+ my $cid = $cdom.'_'.$cnum;
+ if (!exists($allroles{$cid})) {
+ next;
+ }
+ foreach my $role_id (keys(%{$content{'roles'}})) {
+ my @sections = @{$content{'roles'}{$role_id}{'section'}};
+ my @groups = @{$content{'roles'}{$role_id}{'group'}};
+ my @status = @{$content{'roles'}{$role_id}{'access'}};
+ my @roles = @{$content{'roles'}{$role_id}{'role'}};
+ foreach my $role (keys(%{$allroles{$cid}})) {
+ if ((grep/^all$/,@roles) || (grep/^\Q$role\E$/,@roles)) {
+ foreach my $sec (keys(%{$allroles{$cid}{$role}})) {
+ if (&course_group_datechecker($allroles{$cid}{$role}{$sec},$now,\@status) eq 'ok') {
+ if (grep/^all$/,@sections) {
+ return 'ok';
+ } else {
+ if (grep/^$sec$/,@sections) {
+ return 'ok';
+ }
+ }
+ }
+ }
+ if (keys(%{$allgroups{$cid}}) == 0) {
+ if (grep/^none$/,@groups) {
+ return 'ok';
+ }
+ } else {
+ if (grep/^all$/,@groups) {
+ return 'ok';
+ }
+ foreach my $group (keys(%{$allgroups{$cid}})) {
+ if (grep/^$group$/,@groups) {
+ return 'ok';
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ if ($guest) {
+ return $guest;
+ }
+ }
+ }
+ return;
+}
+
+sub course_group_datechecker {
+ my ($dates,$now,$status) = @_;
+ my ($start,$end) = split(/\./,$dates);
+ if (!$start && !$end) {
+ return 'ok';
+ }
+ if (grep/^active$/,@{$status}) {
+ if (((!$start) || ($start && $start <= $now)) && ((!$end) || ($end && $end >= $now))) {
+ return 'ok';
+ }
+ }
+ if (grep/^previous$/,@{$status}) {
+ if ($end > $now ) {
+ return 'ok';
+ }
+ }
+ if (grep/^future$/,@{$status}) {
+ if ($start > $now) {
+ return 'ok';
+ }
+ }
+ return;
+}
+
+sub parse_portfolio_url {
+ my ($url) = @_;
+
+ my ($type,$udom,$unum,$group,$file_name);
+
+ if ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) {
+ $type = 1;
+ $udom = $1;
+ $unum = $2;
+ $file_name = $3;
+ } elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
+ $type = 2;
+ $udom = $1;
+ $unum = $2;
+ $group = $3;
+ $file_name = $3.'/'.$4;
+ }
+ if (wantarray) {
+ return ($type,$udom,$unum,$file_name,$group);
+ }
+ return $type;
+}
+
+sub is_portfolio_url {
+ my ($url) = @_;
+ return scalar(&parse_portfolio_url($url));
+}
+
+sub is_portfolio_file {
+ my ($file) = @_;
+ if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {
+ return 1;
+ }
+ return;
+}
+
+
# ---------------------------------------------- Custom access rule evaluation
sub customaccess {
my ($priv,$uri)=@_;
- my ($urole,$urealm)=split(/\./,$env{'request.role'});
- $urealm=~s/^\W//;
- my ($udom,$ucrs,$usec)=split(/\//,$urealm);
+ my ($urole,$urealm)=split(/\./,$env{'request.role'},2);
+ my (undef,$udom,$ucrs,$usec)=split(/\//,$urealm);
+ $udom = &LONCAPA::clean_domain($udom);
+ $ucrs = &LONCAPA::clean_username($ucrs);
my $access=0;
- foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
- my ($effect,$realm,$role)=split(/\:/,$_);
+ foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
+ my ($effect,$realm,$role)=split(/\:/,$right);
if ($role) {
if ($role ne $urole) { next; }
}
- foreach (split(/\s*\,\s*/,$realm)) {
- my ($tdom,$tcrs,$tsec)=split(/\_/,$_);
+ foreach my $scope (split(/\s*\,\s*/,$realm)) {
+ my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
if ($tdom) {
if ($tdom ne $udom) { next; }
}
@@ -3065,23 +3672,66 @@ sub customaccess {
# ------------------------------------------------- Check for a user privilege
sub allowed {
- my ($priv,$uri,$symb)=@_;
+ my ($priv,$uri,$symb,$role)=@_;
+ my $ver_orguri=$uri;
$uri=&deversion($uri);
my $orguri=$uri;
$uri=&declutter($uri);
-
+
+ if ($priv eq 'evb') {
+# Evade communication block restrictions for specified role in a course
+ if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
+ return $1;
+ } else {
+ return;
+ }
+ }
+
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
# Free bre access to adm and meta resources
- if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|))
- || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
+ if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$}))
+ || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) ))
+ && ($priv eq 'bre')) {
return 'F';
}
# Free bre access to user's own portfolio contents
- my ($space,$domain,$name,$dir)=split('/',$uri);
+ my ($space,$domain,$name,@dir)=split('/',$uri);
if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&
- ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {
- return 'F';
+ ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
+ my %setters;
+ my ($startblock,$endblock) =
+ &Apache::loncommon::blockcheck(\%setters,'port');
+ if ($startblock && $endblock) {
+ return 'B';
+ } else {
+ return 'F';
+ }
+ }
+
+# bre access to group portfolio for rgf priv in group, or mdg or vcg in course.
+ if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups')
+ && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {
+ if (exists($env{'request.course.id'})) {
+ my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+ my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+ if (($domain eq $cdom) && ($name eq $cnum)) {
+ my $courseprivid=$env{'request.course.id'};
+ $courseprivid=~s/\_/\//;
+ if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid
+ .'/'.$dir[1]} =~/rgf\&([^\:]*)/) {
+ return $1;
+ } else {
+ if ($env{'request.course.sec'}) {
+ $courseprivid.='/'.$env{'request.course.sec'};
+ }
+ if ($env{'user.priv.'.$env{'request.role'}.'./'.
+ $courseprivid} =~/(mdg|vcg)\&([^\:]*)/) {
+ return $2;
+ }
+ }
+ }
+ }
}
# Free bre to public access
@@ -3147,14 +3797,6 @@ sub allowed {
$thisallowed.=$1;
}
-# Group: uri itself is a group
- my $groupuri=$uri;
- $groupuri=~s/^([^\/])/\/$1/;
- if ($env{'user.priv.'.$env{'request.role'}.'.'.$groupuri}
- =~/\Q$priv\E\&([^\:]*)/) {
- $thisallowed.=$1;
- }
-
# URI is an uploaded document for this course, default permissions don't matter
# not allowing 'edit' access (editupload) to uploaded course docs
if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
@@ -3166,7 +3808,7 @@ sub allowed {
$thisallowed.=$1;
}
} else {
- my $refuri=$env{'httpref.'.$orguri};
+ my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
if ($refuri) {
if ($refuri =~ m|^/adm/|) {
$thisallowed='F';
@@ -3181,6 +3823,13 @@ sub allowed {
}
}
+ if ($priv eq 'bre'
+ && $thisallowed ne 'F'
+ && $thisallowed ne '2'
+ && &is_portfolio_url($uri)) {
+ $thisallowed = &portfolio_access($uri);
+ }
+
# Full access at system, domain or course-wide level? Exit.
if ($thisallowed=~/F/) {
@@ -3228,14 +3877,14 @@ sub allowed {
if ($checkreferer) {
my $refuri=$env{'httpref.'.$orguri};
unless ($refuri) {
- foreach (keys %env) {
- if ($_=~/^httpref\..*\*/) {
- my $pattern=$_;
+ foreach my $key (keys(%env)) {
+ if ($key=~/^httpref\..*\*/) {
+ my $pattern=$key;
$pattern=~s/^httpref\.\/res\///;
$pattern=~s/\*/\[\^\/\]\+/g;
$pattern=~s/\//\\\//g;
if ($orguri=~/$pattern/) {
- $refuri=$env{$_};
+ $refuri=$env{$key};
}
}
}
@@ -3298,7 +3947,7 @@ sub allowed {
my ($cdom,$cnum,$csec)=split(/\//,$courseid);
my $prefix='course.'.$cdom.'_'.$cnum.'.';
if ((time-$env{$prefix.'last_cache'})>$expiretime) {
- &coursedescription($courseid);
+ &coursedescription($courseid,{'freshen_cache' => 1});
}
if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)
|| ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
@@ -3331,7 +3980,13 @@ sub allowed {
#
unless ($env{'request.course.id'}) {
- return '1';
+ if ($thisallowed eq 'A') {
+ return 'A';
+ } elsif ($thisallowed eq 'B') {
+ return 'B';
+ } else {
+ return '1';
+ }
}
#
@@ -3394,19 +4049,25 @@ sub allowed {
}
}
+ if ($thisallowed eq 'A') {
+ return 'A';
+ } elsif ($thisallowed eq 'B') {
+ return 'B';
+ }
return 'F';
}
+sub split_uri_for_cond {
+ my $uri=&deversion(&declutter(shift));
+ my @uriparts=split(/\//,$uri);
+ my $filename=pop(@uriparts);
+ my $pathname=join('/',@uriparts);
+ return ($pathname,$filename);
+}
# --------------------------------------------------- Is a resource on the map?
sub is_on_map {
- my $uri=&deversion(&declutter(shift));
- my @uriparts=split(/\//,$uri);
- my $filename=$uriparts[$#uriparts];
- my $pathname=$uri;
- $pathname=~s|/\Q$filename\E$||;
- $pathname=~s/^adm\/wrapper\///;
- $pathname=~s/^adm\/coursedocs\/showdoc\///;
+ my ($pathname,$filename) = &split_uri_for_cond(shift);
#Trying to find the conditional for the file
my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~
/\&\Q$filename\E\:([\d\|]+)\&/);
@@ -3445,8 +4106,8 @@ sub get_symb_from_alias {
sub definerole {
if (allowed('mcr','/')) {
my ($rolename,$sysrole,$domrole,$courole)=@_;
- foreach (split(':',$sysrole)) {
- my ($crole,$cqual)=split(/\&/,$_);
+ foreach my $role (split(':',$sysrole)) {
+ my ($crole,$cqual)=split(/\&/,$role);
if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
if ($pr{'cr:s'}=~/\Q$crole\E\&/) {
if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {
@@ -3454,8 +4115,8 @@ sub definerole {
}
}
}
- foreach (split(':',$domrole)) {
- my ($crole,$cqual)=split(/\&/,$_);
+ foreach my $role (split(':',$domrole)) {
+ my ($crole,$cqual)=split(/\&/,$role);
if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; }
if ($pr{'cr:d'}=~/\Q$crole\E\&/) {
if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) {
@@ -3463,8 +4124,8 @@ sub definerole {
}
}
}
- foreach (split(':',$courole)) {
- my ($crole,$cqual)=split(/\&/,$_);
+ foreach my $role (split(':',$courole)) {
+ my ($crole,$cqual)=split(/\&/,$role);
if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; }
if ($pr{'cr:c'}=~/\Q$crole\E\&/) {
if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {
@@ -3511,13 +4172,25 @@ sub log_query {
my $uhome=&homeserver($uname,$udom);
if ($uhome eq 'no_host') { return 'error: no_host'; }
my $uhost=$hostname{$uhome};
- my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters));
+ my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));
my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
$uhome);
unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; }
return get_query_reply($queryid);
}
+# -------------------------- Update MySQL table for portfolio file
+
+sub update_portfolio_table {
+ my ($uname,$udom,$file_name,$query,$group,$action) = @_;
+ my $homeserver = &homeserver($uname,$udom);
+ my $queryid=
+ &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
+ ':'.&escape($file_name).':'.$action,$homeserver);
+ my $reply = &get_query_reply($queryid);
+ return $reply;
+}
+
# ------- Request retrieval of institutional classlists for course(s)
sub fetch_enrollment_query {
@@ -3532,8 +4205,8 @@ sub fetch_enrollment_query {
}
my $host=$hostname{$homeserver};
my $cmd = '';
- foreach (keys %{$affiliatesref}) {
- $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%';
+ foreach my $affiliate (keys %{$affiliatesref}) {
+ $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
}
$cmd =~ s/%%$//;
$cmd = &escape($cmd);
@@ -3554,18 +4227,18 @@ sub fetch_enrollment_query {
} else {
my @responses = split/:/,$reply;
if ($homeserver eq $perlvar{'lonHostID'}) {
- foreach (@responses) {
- my ($key,$value) = split/=/,$_;
+ foreach my $line (@responses) {
+ my ($key,$value) = split(/=/,$line,2);
$$replyref{$key} = $value;
}
} else {
my $pathname = $perlvar{'lonDaemons'}.'/tmp';
- foreach (@responses) {
- my ($key,$value) = split/=/,$_;
+ foreach my $line (@responses) {
+ my ($key,$value) = split(/=/,$line);
$$replyref{$key} = $value;
if ($value > 0) {
- foreach (@{$$affiliatesref{$key}}) {
- my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml';
+ foreach my $item (@{$$affiliatesref{$key}}) {
+ my $filename = $dom.'_'.$key.'_'.$item.'_classlist.xml';
my $destname = $pathname.'/'.$filename;
my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
if ($xml_classlist =~ /^error/) {
@@ -3639,7 +4312,7 @@ sub auto_run {
my $response = &reply('autorun:'.$cdom,$homeserver);
return $response;
}
-
+
sub auto_get_sections {
my ($cnum,$cdom,$inst_coursecode) = @_;
my $homeserver = &homeserver($cnum,$cdom);
@@ -3650,21 +4323,21 @@ sub auto_get_sections {
}
return @secs;
}
-
+
sub auto_new_course {
my ($cnum,$cdom,$inst_course_id,$owner) = @_;
my $homeserver = &homeserver($cnum,$cdom);
my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
return $response;
}
-
+
sub auto_validate_courseID {
my ($cnum,$cdom,$inst_course_id) = @_;
my $homeserver = &homeserver($cnum,$cdom);
my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));
return $response;
}
-
+
sub auto_create_password {
my ($cnum,$cdom,$authparam) = @_;
my $homeserver = &homeserver($cnum,$cdom);
@@ -3679,44 +4352,171 @@ sub auto_create_password {
return ($authparam,$create_passwd,$authchk);
}
+sub auto_photo_permission {
+ my ($cnum,$cdom,$students) = @_;
+ my $homeserver = &homeserver($cnum,$cdom);
+ my ($outcome,$perm_reqd,$conditions) =
+ split(/:/,&unescape(&reply('autophotopermission:'.$cdom,$homeserver)),3);
+ if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
+ return (undef,undef);
+ }
+ return ($outcome,$perm_reqd,$conditions);
+}
+
+sub auto_checkphotos {
+ my ($uname,$udom,$pid) = @_;
+ my $homeserver = &homeserver($uname,$udom);
+ my ($result,$resulttype);
+ my $outcome = &unescape(&reply('autophotocheck:'.&escape($udom).':'.
+ &escape($uname).':'.&escape($pid),
+ $homeserver));
+ if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
+ return (undef,undef);
+ }
+ if ($outcome) {
+ ($result,$resulttype) = split(/:/,$outcome);
+ }
+ return ($result,$resulttype);
+}
+
+sub auto_photochoice {
+ my ($cnum,$cdom) = @_;
+ my $homeserver = &homeserver($cnum,$cdom);
+ my ($update,$comment) = split(/:/,&unescape(&reply('autophotochoice:'.
+ &escape($cdom),
+ $homeserver)));
+ if ($update =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
+ return (undef,undef);
+ }
+ return ($update,$comment);
+}
+
+sub auto_photoupdate {
+ my ($affiliatesref,$dom,$cnum,$photo) = @_;
+ my $homeserver = &homeserver($cnum,$dom);
+ my $host=$hostname{$homeserver};
+ my $cmd = '';
+ my $maxtries = 1;
+ foreach my $affiliate (keys(%{$affiliatesref})) {
+ $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
+ }
+ $cmd =~ s/%%$//;
+ $cmd = &escape($cmd);
+ my $query = 'institutionalphotos';
+ my $queryid=&reply("querysend:".$query.':'.$dom.':'.$cnum.':'.$cmd,$homeserver);
+ unless ($queryid=~/^\Q$host\E\_/) {
+ &logthis('institutionalphotos: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' and course: '.$cnum);
+ return 'error: '.$queryid;
+ }
+ my $reply = &get_query_reply($queryid);
+ my $tries = 1;
+ while (($reply=~/^timeout/) && ($tries < $maxtries)) {
+ $reply = &get_query_reply($queryid);
+ $tries ++;
+ }
+ if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
+ &logthis('institutionalphotos error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' course: '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
+ } else {
+ my @responses = split(/:/,$reply);
+ my $outcome = shift(@responses);
+ foreach my $item (@responses) {
+ my ($key,$value) = split(/=/,$item);
+ $$photo{$key} = $value;
+ }
+ return $outcome;
+ }
+ return 'error';
+}
+
sub auto_instcode_format {
- my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;
+ my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,
+ $cat_order) = @_;
my $courses = '';
- my $homeserver;
+ my @homeservers;
if ($caller eq 'global') {
- foreach my $tryserver (keys %libserv) {
+ foreach my $tryserver (keys(%libserv)) {
if ($hostdom{$tryserver} eq $codedom) {
- $homeserver = $tryserver;
- last;
+ if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
+ push(@homeservers,$tryserver);
+ }
}
}
- if (($env{'user.name'}) && ($env{'user.domain'} eq $codedom)) {
- $homeserver = &homeserver($env{'user.name'},$codedom);
- }
} else {
- $homeserver = &homeserver($caller,$codedom);
+ push(@homeservers,&homeserver($caller,$codedom));
}
- foreach (keys %{$instcodes}) {
- $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';
+ foreach my $code (keys(%{$instcodes})) {
+ $courses .= &escape($code).'='.&escape($$instcodes{$code}).'&';
}
chop($courses);
- my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver);
- unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
- my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response;
- %{$codes} = &str2hash($codes_str);
- @{$codetitles} = &str2array($codetitles_str);
- %{$cat_titles} = &str2hash($cat_titles_str);
- %{$cat_order} = &str2hash($cat_order_str);
+ my $ok_response = 0;
+ my $response;
+ while (@homeservers > 0 && $ok_response == 0) {
+ my $server = shift(@homeservers);
+ $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
+ if ($response !~ /(con_lost|error|no_such_host|refused)/) {
+ my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =
+ split/:/,$response;
+ %{$codes} = (%{$codes},&str2hash($codes_str));
+ push(@{$codetitles},&str2array($codetitles_str));
+ %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
+ %{$cat_order} = (%{$cat_order},&str2hash($cat_order_str));
+ $ok_response = 1;
+ }
+ }
+ if ($ok_response) {
return 'ok';
+ } else {
+ return $response;
+ }
+}
+
+sub auto_instcode_defaults {
+ my ($domain,$returnhash,$code_order) = @_;
+ my @homeservers;
+ foreach my $tryserver (keys(%libserv)) {
+ if ($hostdom{$tryserver} eq $domain) {
+ if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
+ push(@homeservers,$tryserver);
+ }
+ }
+ }
+ my $ok_response = 0;
+ my $response;
+ while (@homeservers > 0 && $ok_response == 0) {
+ my $server = shift(@homeservers);
+ $response=&reply('autoinstcodedefaults:'.$domain,$server);
+ if ($response !~ /(con_lost|error|no_such_host|refused)/) {
+ foreach my $pair (split(/\&/,$response)) {
+ my ($name,$value)=split(/\=/,$pair);
+ if ($name eq 'code_order') {
+ @{$code_order} = split(/\&/,&unescape($value));
+ } else {
+ $returnhash->{&unescape($name)}=&unescape($value);
+ }
+ }
+ $ok_response = 1;
+ }
}
+ if ($ok_response) {
+ return 'ok';
+ } else {
+ return $response;
+ }
+}
+
+sub auto_validate_class_sec {
+ my ($cdom,$cnum,$owner,$inst_class) = @_;
+ my $homeserver = &homeserver($cnum,$cdom);
+ my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
+ &escape($owner).':'.$cdom,$homeserver);
return $response;
}
# ------------------------------------------------------- Course Group routines
sub get_coursegroups {
- my ($cdom,$cnum,$group) = @_;
- return(&dump('coursegroups',$cdom,$cnum,$group));
+ my ($cdom,$cnum,$group,$namespace) = @_;
+ return(&dump($namespace,$cdom,$cnum,$group));
}
sub modify_coursegroup {
@@ -3724,12 +4524,46 @@ sub modify_coursegroup {
return(&put('coursegroups',$groupsettings,$cdom,$cnum));
}
+sub toggle_coursegroup_status {
+ my ($cdom,$cnum,$group,$action) = @_;
+ my ($from_namespace,$to_namespace);
+ if ($action eq 'delete') {
+ $from_namespace = 'coursegroups';
+ $to_namespace = 'deleted_groups';
+ } else {
+ $from_namespace = 'deleted_groups';
+ $to_namespace = 'coursegroups';
+ }
+ my %curr_group = &get_coursegroups($cdom,$cnum,$group,$from_namespace);
+ if (my $tmp = &error(%curr_group)) {
+ &Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom);
+ return ('read error',$tmp);
+ } else {
+ my %savedsettings = %curr_group;
+ my $result = &put($to_namespace,\%savedsettings,$cdom,$cnum);
+ my $deloutcome;
+ if ($result eq 'ok') {
+ $deloutcome = &del($from_namespace,[$group],$cdom,$cnum);
+ } else {
+ return ('write error',$result);
+ }
+ if ($deloutcome eq 'ok') {
+ return 'ok';
+ } else {
+ return ('delete error',$deloutcome);
+ }
+ }
+}
+
sub modify_group_roles {
my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
my $role = 'gr/'.&escape($userprivs);
my ($uname,$udom) = split(/:/,$user);
my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
+ if ($result eq 'ok') {
+ &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
+ }
return $result;
}
@@ -3744,7 +4578,7 @@ sub get_active_groups {
my $now = time;
my %groups = ();
foreach my $key (keys(%env)) {
- if ($key =~ m-user\.role\.gr\./([^/]+)/([^/]+)/(\w+)$-) {
+ if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) {
my ($start,$end) = split(/\./,$env{$key});
if (($end!=0) && ($end<$now)) { next; }
if (($start!=0) && ($start>$now)) { next; }
@@ -3763,38 +4597,51 @@ sub get_group_membership {
sub get_users_groups {
my ($udom,$uname,$courseid) = @_;
+ my @usersgroups;
my $cachetime=1800;
- $courseid=~s/\_/\//g;
- $courseid=~s/^(\w)/\/$1/;
my $hashid="$udom:$uname:$courseid";
- my ($result,$cached)=&is_cached_new('getgroups',$hashid);
- if (defined($cached)) { return $result; }
-
- my %roleshash = &dump('roles',$udom,$uname,$courseid);
- my ($tmp) = keys(%roleshash);
- if ($tmp=~/^error:/) {
- &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);
- return '';
- } else {
- my $grouplist;
- foreach my $key (keys %roleshash) {
- if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
- unless ($roleshash{$key} =~ /_1_1$/) { # deleted membership
- $grouplist .= $1.':';
+ my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
+ if (defined($cached)) {
+ @usersgroups = split(/:/,$grouplist);
+ } else {
+ $grouplist = '';
+ my $courseurl = &courseid_to_courseurl($courseid);
+ my %roleshash = &dump('roles',$udom,$uname,$courseurl);
+ my $access_end = $env{'course.'.$courseid.
+ '.default_enrollment_end_date'};
+ my $now = time;
+ foreach my $key (keys(%roleshash)) {
+ if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) {
+ my $group = $1;
+ if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
+ my $start = $2;
+ my $end = $1;
+ if ($start == -1) { next; } # deleted from group
+ if (($start!=0) && ($start>$now)) { next; }
+ if (($end!=0) && ($end<$now)) {
+ if ($access_end && $access_end < $now) {
+ if ($access_end - $end < 86400) {
+ push(@usersgroups,$group);
+ }
+ }
+ next;
+ }
+ push(@usersgroups,$group);
}
}
}
- $grouplist =~ s/:$//;
- return &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
+ @usersgroups = &sort_course_groups($courseid,@usersgroups);
+ $grouplist = join(':',@usersgroups);
+ &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
}
+ return @usersgroups;
}
sub devalidate_getgroups_cache {
my ($udom,$uname,$cdom,$cnum)=@_;
my $courseid = $cdom.'_'.$cnum;
- $courseid=~s/\_/\//g;
- $courseid=~s/^(\w)/\/$1/;
+
my $hashid="$udom:$uname:$courseid";
&devalidate_cache_new('getgroups',$hashid);
}
@@ -3802,8 +4649,28 @@ sub devalidate_getgroups_cache {
# ------------------------------------------------------------------ Plain Text
sub plaintext {
- my $short=shift;
- return &Apache::lonlocal::mt($prp{$short});
+ my ($short,$type,$cid) = @_;
+ if ($short =~ /^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',
+ );
+ 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
@@ -3813,7 +4680,7 @@ sub assignrole {
my $mrole;
if ($role =~ /^cr\//) {
my $cwosec=$url;
- $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
+ $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
unless (&allowed('ccr',$cwosec)) {
&logthis('Refused custom assignrole: '.
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
@@ -3823,7 +4690,7 @@ sub assignrole {
$mrole='cr';
} elsif ($role =~ /^gr\//) {
my $cwogrp=$url;
- $cwogrp=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
+ $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
unless (&allowed('mdg',$cwogrp)) {
&logthis('Refused group assignrole: '.
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
@@ -3833,7 +4700,7 @@ sub assignrole {
$mrole='gr';
} else {
my $cwosec=$url;
- $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
+ $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) {
&logthis('Refused assignrole: '.
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
@@ -3852,6 +4719,8 @@ sub assignrole {
$command.='_0_'.$start;
}
}
+ my $origstart = $start;
+ my $origend = $end;
# actually delete
if ($deleteflag) {
if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
@@ -3869,6 +4738,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;
}
@@ -3906,8 +4780,8 @@ sub modifyuser {
$umode, $upass, $first,
$middle, $last, $gene,
$forceid, $desiredhome, $email)=@_;
- $udom=~s/\W//g;
- $uname=~s/\W//g;
+ $udom= &LONCAPA::clean_domain($udom);
+ $uname=&LONCAPA::clean_username($uname);
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.
$last.', '.$gene.'(forceid: '.$forceid.')'.
@@ -4056,8 +4930,8 @@ sub modify_student_enrollment {
['firstname','middlename','lastname', 'generation','id']
,$udom,$uname);
- #foreach (keys(%tmp)) {
- # &logthis("key $_ = ".$tmp{$_});
+ #foreach my $key (keys(%tmp)) {
+ # &logthis("key $key = ".$tmp{$key});
#}
$first = $tmp{'firstname'} if (!defined($first) || $first eq '');
$middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');
@@ -4115,8 +4989,8 @@ sub writecoursepref {
return 'error: no such course';
}
my $cstring='';
- foreach (keys %prefs) {
- $cstring.=escape($_).'='.escape($prefs{$_}).'&';
+ foreach my $pref (keys(%prefs)) {
+ $cstring.=&escape($pref).'='.&escape($prefs{$pref}).'&';
}
$cstring=~s/\&$//;
return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
@@ -4125,7 +4999,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)) {
@@ -4162,7 +5037,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;
@@ -4190,6 +5066,16 @@ ENDINITMAP
return '/'.$udom.'/'.$uname;
}
+sub is_course {
+ my ($cdom,$cnum) = @_;
+ my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
+ undef,'.');
+ if (exists($courses{$cdom.'_'.$cnum})) {
+ return 1;
+ }
+ return 0;
+}
+
# ---------------------------------------------------------- Assign Custom Role
sub assigncustomrole {
@@ -4232,14 +5118,28 @@ 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';
}
}
+sub declutter_portfile {
+ my ($file) = @_;
+ &logthis("got $file");
+ $file =~ s-^(/portfolio/|portfolio/)-/-;
+ &logthis("ret $file");
+ return $file;
+}
+
# ------------------------------------------------------------- Mark as Read Only
sub mark_as_readonly {
@@ -4248,6 +5148,7 @@ sub mark_as_readonly {
my ($tmp)=keys(%current_permissions);
if ($tmp=~/^error:/) { undef(%current_permissions); }
foreach my $file (@{$files}) {
+ $file = &declutter_portfile($file);
push(@{$current_permissions{$file}},$what);
}
&put('file_permissions',\%current_permissions,$domain,$user);
@@ -4306,66 +5207,273 @@ sub files_not_in_path {
my $filename = $user."savedfiles";
my @return_files;
my $path_part;
- open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
- while () {
+ open(IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
+ while (my $line = ) {
#ok, I know it's clunky, but I want it to work
- my @paths_and_file = split m!/!, $_;
- my $file_part = pop (@paths_and_file);
- chomp ($file_part);
- my $path_part = join ('/', @paths_and_file);
+ my @paths_and_file = split(m|/|, $line);
+ my $file_part = pop(@paths_and_file);
+ chomp($file_part);
+ my $path_part = join('/', @paths_and_file);
$path_part .= '/';
my $path_and_file = $path_part.$file_part;
if ($path_part ne $path) {
- push (@return_files, ($path_and_file));
+ push(@return_files, ($path_and_file));
}
}
- close (OUT);
+ close(OUT);
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 {
+ 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 {
+ my ($current_permissions,$group,$file) = @_;
+ my %access;
+ my $real_file = $file;
+ $file =~ s/\.meta$//;
+ if (defined($file)) {
+ if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') {
+ foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) {
+ $access{$real_file}{$control} = $$current_permissions{$file."\0".$control};
+ }
+ }
+ } else {
+ foreach my $key (keys(%{$current_permissions})) {
+ if ($key =~ /\0accesscontrol$/) {
+ if (defined($group)) {
+ if ($key !~ m-^\Q$group\E/-) {
+ next;
+ }
+ }
+ my ($fullpath) = split(/\0/,$key);
+ if (ref($$current_permissions{$key}) eq 'HASH') {
+ foreach my $control (keys(%{$$current_permissions{$key}})) {
+ $access{$fullpath}{$control}=$$current_permissions{$fullpath."\0".$control};
+ }
+ }
+ }
+ }
+ }
+ return %access;
+}
+
+sub modify_access_controls {
+ my ($file_name,$changes,$domain,$user)=@_;
+ my ($outcome,$deloutcome);
+ my %store_permissions;
+ my %new_values;
+ my %new_control;
+ my %translation;
+ my @deletions = ();
+ my $now = time;
+ if (exists($$changes{'activate'})) {
+ if (ref($$changes{'activate'}) eq 'HASH') {
+ my @newitems = sort(keys(%{$$changes{'activate'}}));
+ my $numnew = scalar(@newitems);
+ for (my $i=0; $i<$numnew; $i++) {
+ my $newkey = $newitems[$i];
+ my $newid = &Apache::loncommon::get_cgi_id();
+ if ($newkey =~ /^\d+:/) {
+ $newkey =~ s/^(\d+)/$newid/;
+ $translation{$1} = $newid;
+ } elsif ($newkey =~ /^\d+_\d+_\d+:/) {
+ $newkey =~ s/^(\d+_\d+_\d+)/$newid/;
+ $translation{$1} = $newid;
+ }
+ $new_values{$file_name."\0".$newkey} =
+ $$changes{'activate'}{$newitems[$i]};
+ $new_control{$newkey} = $now;
+ }
+ }
+ }
+ my %todelete;
+ my %changed_items;
+ foreach my $action ('delete','update') {
+ if (exists($$changes{$action})) {
+ if (ref($$changes{$action}) eq 'HASH') {
+ foreach my $key (keys(%{$$changes{$action}})) {
+ my ($itemnum) = ($key =~ /^([^:]+):/);
+ if ($action eq 'delete') {
+ $todelete{$itemnum} = 1;
+ } else {
+ $changed_items{$itemnum} = $key;
+ }
+ }
+ }
+ }
+ }
+ # get lock on access controls for file.
+ my $lockhash = {
+ $file_name."\0".'locked_access_records' => $env{'user.name'}.
+ ':'.$env{'user.domain'},
+ };
+ my $tries = 0;
+ my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
+
+ while (($gotlock ne 'ok') && $tries <3) {
+ $tries ++;
+ sleep 1;
+ $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
+ }
+ if ($gotlock eq 'ok') {
+ my %curr_permissions = &dump('file_permissions',$domain,$user,$file_name);
+ my ($tmp)=keys(%curr_permissions);
+ if ($tmp=~/^error:/) { undef(%curr_permissions); }
+ if (exists($curr_permissions{$file_name."\0".'accesscontrol'})) {
+ my $curr_controls = $curr_permissions{$file_name."\0".'accesscontrol'};
+ if (ref($curr_controls) eq 'HASH') {
+ foreach my $control_item (keys(%{$curr_controls})) {
+ my ($itemnum) = ($control_item =~ /^([^:]+):/);
+ if (defined($todelete{$itemnum})) {
+ push(@deletions,$file_name."\0".$control_item);
+ } else {
+ if (defined($changed_items{$itemnum})) {
+ $new_control{$changed_items{$itemnum}} = $now;
+ push(@deletions,$file_name."\0".$control_item);
+ $new_values{$file_name."\0".$changed_items{$itemnum}} = $$changes{'update'}{$changed_items{$itemnum}};
+ } else {
+ $new_control{$control_item} = $$curr_controls{$control_item};
+ }
+ }
+ }
+ }
+ }
+ $deloutcome = &del('file_permissions',\@deletions,$domain,$user);
+ $new_values{$file_name."\0".'accesscontrol'} = \%new_control;
+ $outcome = &put('file_permissions',\%new_values,$domain,$user);
+ # remove lock
+ my @del_lock = ($file_name."\0".'locked_access_records');
+ my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
+ my ($file,$group);
+ if (&is_course($domain,$user)) {
+ ($group,$file) = split(/\//,$file_name,2);
+ } else {
+ $file = $file_name;
+ }
+ my $sqlresult =
+ &update_portfolio_table($user,$domain,$file,'portfolio_access',
+ $group);
+ } else {
+ $outcome = "error: could not obtain lockfile\n";
+ }
+ return ($outcome,$deloutcome,\%new_values,\%translation);
+}
+
+sub make_public_indefinitely {
+ my ($requrl) = @_;
+ my $now = time;
+ my $action = 'activate';
+ my $aclnum = 0;
+ if (&is_portfolio_url($requrl)) {
+ my (undef,$udom,$unum,$file_name,$group) =
+ &parse_portfolio_url($requrl);
+ my $current_perms = &get_portfile_permissions($udom,$unum);
+ my %access_controls = &get_access_controls($current_perms,
+ $group,$file_name);
+ foreach my $key (keys(%{$access_controls{$file_name}})) {
+ my ($num,$scope,$end,$start) =
+ ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
+ if ($scope eq 'public') {
+ if ($start <= $now && $end == 0) {
+ $action = 'none';
+ } else {
+ $action = 'update';
+ $aclnum = $num;
+ }
+ last;
+ }
+ }
+ if ($action eq 'none') {
+ return 'ok';
+ } else {
+ my %changes;
+ my $newend = 0;
+ my $newstart = $now;
+ my $newkey = $aclnum.':public_'.$newend.'_'.$newstart;
+ $changes{$action}{$newkey} = {
+ type => 'public',
+ time => {
+ start => $newstart,
+ end => $newend,
+ },
+ };
+ my ($outcome,$deloutcome,$new_values,$translation) =
+ &modify_access_controls($file_name,\%changes,$udom,$unum);
+ return $outcome;
+ }
+ } else {
+ return 'invalid';
+ }
+}
+
+#------------------------------------------------------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 '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') {
+ foreach my $lock_descriptor(@{$stored_what}) {
+ if ($lock_descriptor eq 'graded') {
+ $readonly_files{$file_name} = 'graded';
+ } elsif ($lock_descriptor eq 'handback') {
+ $readonly_files{$file_name} = 'handback';
+ } else {
+ if (!exists($readonly_files{$file_name})) {
+ $readonly_files{$file_name} = 'locked';
+ }
+ }
+ }
+ }
}
}
}
@@ -4376,24 +5484,28 @@ 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) = @_;
+ $file_name = &declutter_portfile($file_name);
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 $clean_file = &declutter_portfile($file);
+ if (defined($file_name) && ($file_name ne $clean_file)) { next; }
my $current_locks = $current_permissions{$file};
my @new_locks;
my @del_keys;
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') {
+ $compare=join('',@{$locker});
+ if ($compare ne $symb_crs) {
+ push(@new_locks, $locker);
+ }
}
}
if (scalar(@new_locks) > 0) {
@@ -4433,28 +5545,27 @@ sub dirlist {
if($udom) {
if($uname) {
- my $listing=reply('ls2:'.$dirRoot.'/'.$uri,
- homeserver($uname,$udom));
+ my $listing = &reply('ls2:'.$dirRoot.'/'.$uri,
+ &homeserver($uname,$udom));
my @listing_results;
if ($listing eq 'unknown_cmd') {
- $listing=reply('ls:'.$dirRoot.'/'.$uri,
- homeserver($uname,$udom));
+ $listing = &reply('ls:'.$dirRoot.'/'.$uri,
+ &homeserver($uname,$udom));
@listing_results = split(/:/,$listing);
} else {
@listing_results = map { &unescape($_); } split(/:/,$listing);
}
return @listing_results;
} elsif(!defined($alternateDirectoryRoot)) {
- my $tryserver;
- my %allusers=();
- foreach $tryserver (keys %libserv) {
+ my %allusers;
+ foreach my $tryserver (keys(%libserv)) {
if($hostdom{$tryserver} eq $udom) {
- my $listing=reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
- $udom, $tryserver);
+ my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
+ $udom, $tryserver);
my @listing_results;
if ($listing eq 'unknown_cmd') {
- $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
- $udom, $tryserver);
+ $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
+ $udom, $tryserver);
@listing_results = split(/:/,$listing);
} else {
@listing_results =
@@ -4463,40 +5574,36 @@ sub dirlist {
if ($listing_results[0] ne 'no_such_dir' &&
$listing_results[0] ne 'empty' &&
$listing_results[0] ne 'con_lost') {
- foreach (@listing_results) {
- my ($entry,@stat)=split(/&/,$_);
- $allusers{$entry}=1;
+ foreach my $line (@listing_results) {
+ my ($entry) = split(/&/,$line,2);
+ $allusers{$entry} = 1;
}
}
}
}
my $alluserstr='';
- foreach (sort keys %allusers) {
- $alluserstr.=$_.'&user:';
+ foreach my $user (sort(keys(%allusers))) {
+ $alluserstr.=$user.'&user:';
}
$alluserstr=~s/:$//;
return split(/:/,$alluserstr);
} else {
- my @emptyResults = ();
- push(@emptyResults, 'missing user name');
- return split(':',@emptyResults);
+ return ('missing user name');
}
} elsif(!defined($alternateDirectoryRoot)) {
my $tryserver;
my %alldom=();
- foreach $tryserver (keys %libserv) {
+ foreach $tryserver (keys(%libserv)) {
$alldom{$hostdom{$tryserver}}=1;
}
my $alldomstr='';
- foreach (sort keys %alldom) {
- $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:';
+ foreach my $domain (sort(keys(%alldom))) {
+ $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain:';
}
$alldomstr=~s/:$//;
return split(/:/,$alldomstr);
} else {
- my @emptyResults = ();
- push(@emptyResults, 'missing domain');
- return split(':',@emptyResults);
+ return ('missing domain');
}
}
@@ -4514,8 +5621,8 @@ sub dirlist {
##
sub GetFileTimestamp {
my ($studentDomain,$studentName,$filename,$root)=@_;
- $studentDomain=~s/\W//g;
- $studentName=~s/\W//g;
+ $studentDomain = &LONCAPA::clean_domain($studentDomain);
+ $studentName = &LONCAPA::clean_username($studentName);
my $subdir=$studentName.'__';
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
my $proname="$studentDomain/$subdir/$studentName";
@@ -4531,13 +5638,64 @@ sub GetFileTimestamp {
}
}
+sub stat_file {
+ my ($uri) = @_;
+ $uri = &clutter_with_no_wrapper($uri);
+
+ my ($udom,$uname,$file,$dir);
+ if ($uri =~ m-^/(uploaded|editupload)/-) {
+ ($udom,$uname,$file) =
+ ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);
+ $file = 'userfiles/'.$file;
+ $dir = &propath($udom,$uname);
+ }
+ if ($uri =~ m-^/res/-) {
+ ($udom,$uname) =
+ ($uri =~ m-/(?:res)/?($match_domain)/?($match_username)/-);
+ $file = $uri;
+ }
+
+ if (!$udom || !$uname || !$file) {
+ # unable to handle the uri
+ return ();
+ }
+
+ my ($result) = &dirlist($file,$udom,$uname,$dir);
+ my @stats = split('&', $result);
+
+ if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
+ shift(@stats); #filename is first
+ return @stats;
+ }
+ return ();
+}
+
# -------------------------------------------------------- Value of a Condition
+# gets the value of a specific preevaluated condition
+# stored in the string $env{user.state.}
+# or looks up a condition reference in the bighash and if if hasn't
+# already been evaluated recurses into docondval to get the value of
+# the condition, then memoizing it to
+# $env{user.state..}
sub directcondval {
my $number=shift;
if (!defined($env{'user.state.'.$env{'request.course.id'}})) {
&Apache::lonuserstate::evalstate();
}
+ if (exists($env{'user.state.'.$env{'request.course.id'}.".$number"})) {
+ return $env{'user.state.'.$env{'request.course.id'}.".$number"};
+ } elsif ($number =~ /^_/) {
+ my $sub_condition;
+ if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
+ &GDBM_READER(),0640)) {
+ $sub_condition=$bighash{'conditions'.$number};
+ untie(%bighash);
+ }
+ my $value = &docondval($sub_condition);
+ &appenv('user.state.'.$env{'request.course.id'}.".$number" => $value);
+ return $value;
+ }
if ($env{'user.state.'.$env{'request.course.id'}}) {
return substr($env{'user.state.'.$env{'request.course.id'}},$number,1);
} else {
@@ -4545,43 +5703,49 @@ sub directcondval {
}
}
+# get the collection of conditions for this resource
sub condval {
my $condidx=shift;
- my $result=0;
my $allpathcond='';
- foreach (split(/\|/,$condidx)) {
- if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$_})) {
- $allpathcond.=
- '('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$_}.')|';
- }
+ foreach my $cond (split(/\|/,$condidx)) {
+ if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond})) {
+ $allpathcond.=
+ '('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond}.')|';
+ }
}
$allpathcond=~s/\|$//;
- if ($env{'request.course.id'}) {
- if ($allpathcond) {
- my $operand='|';
- my @stack;
- foreach ($allpathcond=~/(\d+|\(|\)|\&|\|)/g) {
- if ($_ eq '(') {
- push @stack,($operand,$result)
- } elsif ($_ eq ')') {
- my $before=pop @stack;
- if (pop @stack eq '&') {
- $result=$result>$before?$before:$result;
- } else {
- $result=$result>$before?$result:$before;
- }
- } elsif (($_ eq '&') || ($_ eq '|')) {
- $operand=$_;
- } else {
- my $new=directcondval($_);
- if ($operand eq '&') {
- $result=$result>$new?$new:$result;
- } else {
- $result=$result>$new?$result:$new;
- }
- }
- }
- }
+ return &docondval($allpathcond);
+}
+
+#evaluates an expression of conditions
+sub docondval {
+ my ($allpathcond) = @_;
+ my $result=0;
+ if ($env{'request.course.id'}
+ && defined($allpathcond)) {
+ my $operand='|';
+ my @stack;
+ foreach my $chunk ($allpathcond=~/(\d+|_\d+\.\d+|\(|\)|\&|\|)/g) {
+ if ($chunk eq '(') {
+ push @stack,($operand,$result);
+ } elsif ($chunk eq ')') {
+ my $before=pop @stack;
+ if (pop @stack eq '&') {
+ $result=$result>$before?$before:$result;
+ } else {
+ $result=$result>$before?$result:$before;
+ }
+ } elsif (($chunk eq '&') || ($chunk eq '|')) {
+ $operand=$chunk;
+ } else {
+ my $new=directcondval($chunk);
+ if ($operand eq '&') {
+ $result=$result>$new?$new:$result;
+ } else {
+ $result=$result>$new?$result:$new;
+ }
+ }
+ }
}
return $result;
}
@@ -4594,6 +5758,7 @@ sub devalidatecourseresdata {
&devalidate_cache_new('courseres',$hashid);
}
+
# --------------------------------------------------- Course Resourcedata Query
sub get_courseresdata {
@@ -4698,8 +5863,8 @@ sub EXT_cache_set {
# --------------------------------------------------------- Value of a Variable
sub EXT {
- my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;
+ my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;
unless ($varname) { return ''; }
#get real user name/domain, courseid and symb
my $courseid;
@@ -4708,8 +5873,7 @@ sub EXT {
$symbparm=&get_symb_from_alias($symbparm);
}
if (!($uname && $udom)) {
- (my $cursymb,$courseid,$udom,$uname,$publicuser)=
- &Apache::lonxml::whichuser($symbparm);
+ (my $cursymb,$courseid,$udom,$uname,$publicuser)= &whichuser($symbparm);
if (!$symbparm) { $symbparm=$cursymb; }
} else {
$courseid=$env{'request.course.id'};
@@ -4732,8 +5896,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') {
@@ -4813,10 +5983,21 @@ sub EXT {
return $env{'course.'.$courseid.'.'.$spacequalifierrest};
} elsif ($realm eq 'resource') {
- my $section;
if (defined($courseid) && $courseid eq $env{'request.course.id'}) {
if (!$symbparm) { $symbparm=&symbread(); }
}
+
+ if ($space eq 'title') {
+ if (!$symbparm) { $symbparm = $env{'request.filename'}; }
+ return &gettitle($symbparm);
+ }
+
+ if ($space eq 'map') {
+ my ($map) = &decode_symb($symbparm);
+ return &symbread($map);
+ }
+
+ my ($section, $group, @groups);
my ($courselevelm,$courselevel);
if ($symbparm && defined($courseid) &&
$courseid eq $env{'request.course.id'}) {
@@ -4825,7 +6006,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;
@@ -4833,12 +6014,15 @@ sub EXT {
if (($env{'user.name'} eq $uname) &&
($env{'user.domain'} eq $udom)) {
$section=$env{'request.course.sec'};
+ @groups = split(/:/,$env{'request.course.groups'});
+ @groups=&sort_course_groups($courseid,@groups);
} else {
if (! defined($usection)) {
$section=&getsection($udom,$uname,$courseid);
} else {
$section = $usection;
}
+ @groups = &get_users_groups($udom,$uname,$courseid);
}
my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
@@ -4854,12 +6038,17 @@ sub EXT {
my $userreply=&resdata($uname,$udom,'user',
($courselevelr,$courselevelm,
$courselevel));
-
if (defined($userreply)) { return $userreply; }
# ------------------------------------------------ second, check some of course
+ my $coursereply;
+ if (@groups > 0) {
+ $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
+ $mapparm,$spacequalifierrest);
+ if (defined($coursereply)) { return $coursereply; }
+ }
- my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
+ $coursereply=&resdata($env{'course.'.$courseid.'.num'},
$env{'course.'.$courseid.'.domain'},
'course',
($seclevelr,$seclevelm,$seclevel,
@@ -4921,6 +6110,9 @@ sub EXT {
if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) {
return $env{'environment.'.$spacequalifierrest};
} else {
+ if ($uname eq 'anonymous' && $udom eq '') {
+ return '';
+ }
my %returnhash=&userenvironment($udom,$uname,
$spacequalifierrest);
return $returnhash{$spacequalifierrest};
@@ -4939,12 +6131,55 @@ sub EXT {
return '';
}
+sub check_group_parms {
+ my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
+ my @groupitems = ();
+ my $resultitem;
+ my @levels = ($symbparm,$mapparm,$what);
+ foreach my $group (@{$groups}) {
+ foreach my $level (@levels) {
+ my $item = $courseid.'.['.$group.'].'.$level;
+ push(@groupitems,$item);
+ }
+ }
+ my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
+ $env{'course.'.$courseid.'.domain'},
+ 'course',@groupitems);
+ return $coursereply;
+}
+
+sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
+ my ($courseid,@groups) = @_;
+ @groups = sort(@groups);
+ return @groups;
+}
+
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"};
}
@@ -4953,6 +6188,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;
}
@@ -4983,7 +6232,7 @@ sub metadata {
(($uri =~ m|^/*adm/|) &&
($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
- ($uri =~ m|home/[^/]+/public_html/|)) {
+ ($uri =~ m|home/$match_username/public_html/|)) {
return undef;
}
my $filename=$uri;
@@ -5014,7 +6263,7 @@ sub metadata {
my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring;
- if ($uri !~ m -^(uploaded|editupload)/-) {
+ if ($uri !~ m -^(editupload)/-) {
my $file=&filelocation('',&clutter($filename));
#push(@{$metaentry{$uri.'.file'}},$file);
$metastring=&getfile($file);
@@ -5038,16 +6287,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;
@@ -5095,11 +6344,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 {
@@ -5108,8 +6358,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'};
@@ -5130,14 +6381,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',
@@ -5155,15 +6406,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);
@@ -5199,7 +6457,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'};
@@ -5224,6 +6482,17 @@ sub metadata_generate_part0 {
}
}
+# ------------------------------------------------------ Devalidate title cache
+
+sub devalidate_title_cache {
+ my ($url)=@_;
+ if (!$env{'request.course.id'}) { return; }
+ my $symb=&symbread($url);
+ if (!$symb) { return; }
+ my $key=$env{'request.course.id'}."\0".$symb;
+ &devalidate_cache_new('title',$key);
+}
+
# ------------------------------------------------- Get the title of a resource
sub gettitle {
@@ -5258,14 +6527,21 @@ sub gettitle {
sub get_slot {
my ($which,$cnum,$cdom)=@_;
if (!$cnum || !$cdom) {
- (undef,my $courseid)=&Apache::lonxml::whichuser();
+ (undef,my $courseid)=&whichuser();
$cdom=$env{'course.'.$courseid.'.domain'};
$cnum=$env{'course.'.$courseid.'.num'};
}
- my %slotinfo=&get('slots',[$which],$cdom,$cnum);
- &Apache::lonhomework::showhash(%slotinfo);
- my ($tmp)=keys(%slotinfo);
- if ($tmp=~/^error:/) { return (); }
+ my $key=join("\0",'slots',$cdom,$cnum,$which);
+ my %slotinfo;
+ if (exists($remembered{$key})) {
+ $slotinfo{$which} = $remembered{$key};
+ } else {
+ %slotinfo=&get('slots',[$which],$cdom,$cnum);
+ &Apache::lonhomework::showhash(%slotinfo);
+ my ($tmp)=keys(%slotinfo);
+ if ($tmp=~/^error:/) { return (); }
+ $remembered{$key} = $slotinfo{$which};
+ }
if (ref($slotinfo{$which}) eq 'HASH') {
return %{$slotinfo{$which}};
}
@@ -5280,9 +6556,12 @@ sub symblist {
if (($env{'request.course.fn'}) && (%newhash)) {
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
&GDBM_WRCREAT(),0640)) {
- foreach (keys %newhash) {
- $hash{declutter($_)}=&encode_symb($mapname,$newhash{$_}->[1],
- $newhash{$_}->[0]);
+ foreach my $url (keys %newhash) {
+ next if ($url eq 'last_known'
+ && $env{'form.no_update_last_known'});
+ $hash{declutter($url)}=&encode_symb($mapname,
+ $newhash{$url}->[1],
+ $newhash{$url}->[0]);
}
if (untie(%hash)) {
return 'ok';
@@ -5297,9 +6576,6 @@ sub symblist {
sub symbverify {
my ($symb,$thisurl)=@_;
my $thisfn=$thisurl;
-# wrapper not part of symbs
- $thisfn=~s/^\/adm\/wrapper//;
- $thisfn=~s/^\/adm\/coursedocs\/showdoc\///;
$thisfn=&declutter($thisfn);
# direct jump to resource in page or to a sequence - will construct own symbs
if ($thisfn=~/\.(page|sequence)$/) { return 1; }
@@ -5323,13 +6599,13 @@ sub symbverify {
}
if ($ids) {
# ------------------------------------------------------------------- Has ID(s)
- foreach (split(/\,/,$ids)) {
- my ($mapid,$resid)=split(/\./,$_);
+ foreach my $id (split(/\,/,$ids)) {
+ my ($mapid,$resid)=split(/\./,$id);
if (
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
eq $symb) {
if (($env{'request.role.adv'}) ||
- $bighash{'encrypted_'.$_} eq $env{'request.enc'}) {
+ $bighash{'encrypted_'.$id} eq $env{'request.enc'}) {
$okay=1;
}
}
@@ -5472,10 +6748,10 @@ sub symbread {
} elsif (!$donotrecurse) {
# ------------------------------------------ There is more than one possibility
my $realpossible=0;
- foreach (@possibilities) {
- my $file=$bighash{'src_'.$_};
+ foreach my $id (@possibilities) {
+ my $file=$bighash{'src_'.$id};
if (&allowed('bre',$file)) {
- my ($mapid,$resid)=split(/\./,$_);
+ my ($mapid,$resid)=split(/\./,$id);
if ($bighash{'map_type_'.$mapid} ne 'page') {
$realpossible++;
$syval=&encode_symb($bighash{'map_id_'.$mapid},
@@ -5582,7 +6858,7 @@ sub latest_rnd_algorithm_id {
sub get_rand_alg {
my ($courseid)=@_;
- if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; }
+ if (!$courseid) { $courseid=(&whichuser())[1]; }
if ($courseid) {
return $env{"course.$courseid.rndseed"};
}
@@ -5608,7 +6884,7 @@ sub getCODE {
sub rndseed {
my ($symb,$courseid,$domain,$username)=@_;
- my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser();
+ my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
if (!$symb) {
unless ($symb=$wsymb) { return time; }
}
@@ -5616,6 +6892,7 @@ sub rndseed {
if (!$domain) { $domain=$wdomain; }
if (!$username) { $username=$wusername }
my $which=&get_rand_alg();
+
if (defined(&getCODE())) {
if ($which eq '64bit5') {
return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
@@ -5649,8 +6926,8 @@ sub rndseed_32bit {
my $domainseed=unpack("%32C*",$domain) << 7;
my $courseseed=unpack("%32C*",$courseid);
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
- #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
- #&Apache::lonxml::debug("rndseed :$num:$symb");
+ #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
+ #&logthis("rndseed :$num:$symb");
if ($_64bit) { $num=(($num<<32)>>32); }
return $num;
}
@@ -5670,9 +6947,8 @@ sub rndseed_64bit {
my $num1=$symbchck+$symbseed+$namechck;
my $num2=$nameseed+$domainseed+$courseseed;
- #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
- #&Apache::lonxml::debug("rndseed :$num:$symb");
- if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
+ #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
+ #&logthis("rndseed :$num:$symb");
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
return "$num1,$num2";
}
@@ -5694,8 +6970,9 @@ sub rndseed_64bit2 {
my $num1=$symbchck+$symbseed+$namechck;
my $num2=$nameseed+$domainseed+$courseseed;
- #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
- #&Apache::lonxml::debug("rndseed :$num:$symb");
+ #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
+ #&logthis("rndseed :$num:$symb");
+ if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
return "$num1,$num2";
}
}
@@ -5716,8 +6993,8 @@ sub rndseed_64bit3 {
my $num1=$symbchck+$symbseed+$namechck;
my $num2=$nameseed+$domainseed+$courseseed;
- #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
- #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit");
+ #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
+ #&logthis("rndseed :$num1:$num2:$_64bit");
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
return "$num1:$num2";
@@ -5740,8 +7017,8 @@ sub rndseed_64bit4 {
my $num1=$symbchck+$symbseed+$namechck;
my $num2=$nameseed+$domainseed+$courseseed;
- #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
- #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit");
+ #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
+ #&logthis("rndseed :$num1:$num2:$_64bit");
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
return "$num1:$num2";
@@ -5765,8 +7042,8 @@ sub rndseed_CODE_64bit {
my $courseseed=unpack("%32S*",$courseid.' ');
my $num1=$symbseed+$CODEchck;
my $num2=$CODEseed+$courseseed+$symbchck;
- #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
- #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
+ #&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
+ #&logthis("rndseed :$num1:$num2:$symb");
if ($_64bit) { $num1=(($num1<<32)>>32); }
if ($_64bit) { $num2=(($num2<<32)>>32); }
return "$num1:$num2";
@@ -5784,8 +7061,8 @@ sub rndseed_CODE_64bit4 {
my $courseseed=unpack("%32S*",$courseid.' ');
my $num1=$symbseed+$CODEchck;
my $num2=$CODEseed+$courseseed+$symbchck;
- #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
- #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
+ #&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
+ #&logthis("rndseed :$num1:$num2:$symb");
if ($_64bit) { $num1=(($num1<<32)>>32); }
if ($_64bit) { $num2=(($num2<<32)>>32); }
return "$num1:$num2";
@@ -5846,8 +7123,7 @@ sub ireceipt {
my $return =&recprefix($fucourseid).'-';
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
$env{'request.state'} eq 'construct') {
- &Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname).
- " and ".($cpart%$cudom));
+ #&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom));
$return.= ($cunique%$cuname+
$cunique%$cudom+
@@ -5870,10 +7146,48 @@ sub ireceipt {
sub receipt {
my ($part)=@_;
- my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();
+ my ($symb,$courseid,$domain,$name) = &whichuser();
return &ireceipt($name,$domain,$courseid,$symb,$part);
}
+sub whichuser {
+ my ($passedsymb)=@_;
+ my ($symb,$courseid,$domain,$name,$publicuser);
+ if (defined($env{'form.grade_symb'})) {
+ my ($tmp_courseid)=&get_env_multiple('form.grade_courseid');
+ my $allowed=&allowed('vgr',$tmp_courseid);
+ if (!$allowed &&
+ exists($env{'request.course.sec'}) &&
+ $env{'request.course.sec'} !~ /^\s*$/) {
+ $allowed=&allowed('vgr',$tmp_courseid.
+ '/'.$env{'request.course.sec'});
+ }
+ if ($allowed) {
+ ($symb)=&get_env_multiple('form.grade_symb');
+ $courseid=$tmp_courseid;
+ ($domain)=&get_env_multiple('form.grade_domain');
+ ($name)=&get_env_multiple('form.grade_username');
+ return ($symb,$courseid,$domain,$name,$publicuser);
+ }
+ }
+ if (!$passedsymb) {
+ $symb=&symbread();
+ } else {
+ $symb=$passedsymb;
+ }
+ $courseid=$env{'request.course.id'};
+ $domain=$env{'user.domain'};
+ $name=$env{'user.name'};
+ if ($name eq 'public' && $domain eq 'public') {
+ if (!defined($env{'form.username'})) {
+ $env{'form.username'}.=time.rand(10000000);
+ }
+ $name.=$env{'form.username'};
+ }
+ return ($symb,$courseid,$domain,$name,$publicuser);
+
+}
+
# ------------------------------------------------------------ Serves up a file
# returns either the contents of the file or
# -1 if the file doesn't exist
@@ -5896,61 +7210,60 @@ sub repcopy_userfile {
if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }
if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; }
my ($cdom,$cnum,$filename) =
- ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|);
- my ($info,$rtncode);
+ ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
my $uri="/uploaded/$cdom/$cnum/$filename";
if (-e "$file") {
+# we already have a local copy, check it out
my @fileinfo = stat($file);
+ my $rtncode;
+ my $info;
my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
if ($lwpresp ne 'ok') {
+# there is no such file anymore, even though we had a local copy
if ($rtncode eq '404') {
unlink($file);
}
- #my $ua=new LWP::UserAgent;
- #my $request=new HTTP::Request('GET',&tokenwrapper($uri));
- #my $response=$ua->request($request);
- #if ($response->is_success()) {
- # return $response->content;
- # } else {
- # return -1;
- # }
return -1;
}
if ($info < $fileinfo[9]) {
+# nice, the file we have is up-to-date, just say okay
return 'ok';
+ } else {
+# the file is outdated, get rid of it
+ unlink($file);
}
- $info = '';
- $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
- if ($lwpresp ne 'ok') {
- return -1;
- }
- } else {
- my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
- if ($lwpresp ne 'ok') {
- my $ua=new LWP::UserAgent;
- my $request=new HTTP::Request('GET',&tokenwrapper($uri));
- my $response=$ua->request($request);
- if ($response->is_success()) {
- $info=$response->content;
- } else {
- return -1;
- }
- }
- my @parts = ($cdom,$cnum);
- if ($filename =~ m|^(.+)/[^/]+$|) {
- push @parts, split(/\//,$1);
- }
- my $path = $perlvar{'lonDocRoot'}.'/userfiles';
- foreach my $part (@parts) {
- $path .= '/'.$part;
- if (!-e $path) {
- mkdir($path,0770);
- }
+ }
+# one way or the other, at this point, we don't have the file
+# construct the correct path for the file
+ my @parts = ($cdom,$cnum);
+ if ($filename =~ m|^(.+)/[^/]+$|) {
+ push @parts, split(/\//,$1);
+ }
+ my $path = $perlvar{'lonDocRoot'}.'/userfiles';
+ foreach my $part (@parts) {
+ $path .= '/'.$part;
+ if (!-e $path) {
+ mkdir($path,0770);
}
}
- open(FILE,">$file");
- print FILE $info;
- close(FILE);
+# now the path exists for sure
+# get a user agent
+ my $ua=new LWP::UserAgent;
+ my $transferfile=$file.'.in.transfer';
+# FIXME: this should flock
+ if (-e $transferfile) { return 'ok'; }
+ my $request;
+ $uri=~s/^\///;
+ $request=new HTTP::Request('GET','http://'.$hostname{&homeserver($cnum,$cdom)}.'/raw/'.$uri);
+ my $response=$ua->request($request,$transferfile);
+# did it work?
+ if ($response->is_error()) {
+ unlink($transferfile);
+ &logthis("Userfile repcopy failed for $uri");
+ return -1;
+ }
+# worked, rename the transfer file
+ rename($transferfile,$file);
return 'ok';
}
@@ -5972,6 +7285,10 @@ sub tokenwrapper {
}
}
+# call with reqtype HEAD: get last modification time
+# call with reqtype GET: get the file contents
+# Do not call this with reqtype GET for large files! It loads everything into memory
+#
sub getuploaded {
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
$uri=~s/^\///;
@@ -5997,7 +7314,7 @@ sub readfile {
my $fh;
open($fh,"<$file");
my $a='';
- while (<$fh>) { $a .=$_; }
+ while (my $line = <$fh>) { $a .= $line; }
return $a;
}
@@ -6013,18 +7330,18 @@ sub filelocation {
if ($file=~m:^/~:) { # is a contruction space reference
$location = $file;
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
- } elsif ($file=~m:^/home/[^/]*/public_html/:) {
+ } elsif ($file=~m{^/home/$match_username/public_html/}) {
# is a correct contruction space reference
$location = $file;
} elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
my ($udom,$uname,$filename)=
- ($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-);
+ ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
my $home=&homeserver($uname,$udom);
my $is_me=0;
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/'.
@@ -6055,10 +7372,10 @@ sub hreflocation {
}
if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
$file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
- } elsif ($file=~m-/home/(\w+)/public_html/-) {
- $file=~s-^/home/(\w+)/public_html/-/~$1/-;
+ } elsif ($file=~m-/home/($match_username)/public_html/-) {
+ $file=~s-^/home/($match_username)/public_html/-/~$1/-;
} elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
- $file=~s-^/home/httpd/lonUsers/([^/]*)/./././([^/]*)/userfiles/
+ $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/
-/uploaded/$1/$2/-x;
}
return $file;
@@ -6088,6 +7405,29 @@ sub current_machine_ids {
return @ids;
}
+sub additional_machine_domains {
+ my @domains;
+ open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");
+ while( my $line = <$fh>) {
+ $line =~ s/\s//g;
+ push(@domains,$line);
+ }
+ return @domains;
+}
+
+sub default_login_domain {
+ my $domain = $perlvar{'lonDefDomain'};
+ my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0];
+ foreach my $posdom (¤t_machine_domains(),
+ &additional_machine_domains()) {
+ if (lc($posdom) eq lc($testdomain)) {
+ $domain=$posdom;
+ last;
+ }
+ }
+ return $domain;
+}
+
# ------------------------------------------------------------- Declutters URLs
sub declutter {
@@ -6129,13 +7469,22 @@ sub clutter {
&& $thisfn!~/\.(sequence|page)$/) {
$thisfn='/adm/coursedocs/showdoc'.$thisfn;
} else {
- #&logthis("Got a blank emb style");
+# &logthis("Got a blank emb style");
}
}
}
return $thisfn;
}
+sub clutter_with_no_wrapper {
+ my $uri = &clutter(shift);
+ if ($uri =~ m-^/adm/-) {
+ $uri =~ s-^/adm/wrapper/-/-;
+ $uri =~ s-^/adm/coursedocs/showdoc/-/-;
+ }
+ return $uri;
+}
+
sub freeze_escape {
my ($value)=@_;
if (ref($value)) {
@@ -6145,21 +7494,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)=@_;
@@ -6197,36 +7531,14 @@ sub goodbye {
&logthis(sprintf("%-20s is %s",'hits',$hits));
&flushcourselogs();
&logthis("Shutting down");
- return DONE;
}
BEGIN {
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
unless ($readit) {
{
- # FIXME: Use LONCAPA::Configuration::read_conf here and omit next block
- open(my $config,") {
- if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) {
- my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
- chomp($varvalue);
- $perlvar{$varname}=$varvalue;
- }
- }
- close($config);
-}
-{
- open(my $config,") {
- if ($configline =~ /^[^\#]*PerlSetVar/) {
- my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
- chomp($varvalue);
- $perlvar{$varname}=$varvalue;
- }
- }
- close($config);
+ my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
+ %perlvar = (%perlvar,%{$configvars});
}
# ------------------------------------------------------------ Read domain file
@@ -6236,12 +7548,12 @@ BEGIN {
%domain_auth_arg_def = ();
my $fh;
if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {
- while (<$fh>) {
- next if (/^(\#|\s*$)/);
+ while (my $line = <$fh>) {
+ next if ($line =~ /^(\#|\s*$)/);
# next if /^\#/;
- chomp;
+ chomp $line;
my ($domain, $domain_description, $def_auth, $def_auth_arg,
- $def_lang, $city, $longi, $lati, $primary) = split(/:/,$_);
+ $def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9);
$domain_auth_def{$domain}=$def_auth;
$domain_auth_arg_def{$domain}=$def_auth_arg;
$domaindescription{$domain}=$domain_description;
@@ -6276,7 +7588,7 @@ BEGIN {
}
close($config);
# FIXME: dev server don't want this, production servers _do_ want this
- &get_iphost();
+ #&get_iphost();
}
sub get_iphost {
@@ -6288,7 +7600,7 @@ sub get_iphost {
if (!exists($name_to_ip{$name})) {
$ip = gethostbyname($name);
if (!$ip || length($ip) ne 4) {
- &logthis("Skipping host $id name $name no IP found\n");
+ &logthis("Skipping host $id name $name no IP found");
next;
}
$ip=inet_ntoa($ip);
@@ -6308,7 +7620,9 @@ sub get_iphost {
while (my $configline=<$config>) {
chomp($configline);
if ($configline) {
- $spareid{$configline}=1;
+ my ($host,$type) = split(':',$configline,2);
+ if (!defined($type) || $type eq '') { $type = 'default' };
+ push(@{ $spareid{$type} }, $host);
}
}
close($config);
@@ -6334,8 +7648,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);
@@ -6364,7 +7684,9 @@ sub get_iphost {
}
-$memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
+$memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'],
+ 'compress_threshold'=> 20_000,
+ });
$processmarker='_'.time.'_'.$perlvar{'lonHostID'};
$dumpcount=0;
@@ -6561,6 +7883,13 @@ B: removes all items fr
environment file that matches the regular expression in $regexp. The
values are also delted from the current processes %env.
+=item * get_env_multiple($name)
+
+gets $name from the %env hash, it seemlessly handles the cases where multiple
+values may be defined and end up as an array ref.
+
+returns an array of values
+
=back
=head2 User Information
@@ -6623,13 +7952,13 @@ passed in @what from the requested user'
=item *
-allowed($priv,$uri) : check for a user privilege; returns codes for allowed
-actions
+allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions
F: full access
U,I,K: authentication modes (cxx only)
'': forbidden
1: user needs to choose course
2: browse allowed
+ A: passphrase authentication needed
=item *
@@ -6642,6 +7971,9 @@ and course level
plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
explanation of a user role term
+=item *
+
+get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are optional. Returns a hash of a user's roles, with keys set to colon-sparated $uname,$udom,and $role, and value set to colon-separated start and end times for the role. If no username and domain are specified, will default to current user/domain. Types, roles, and roledoms are references to arrays, of role statuses (active, future or previous), roles (e.g., cc,in, st etc.) and domains of the roles which can be used to restrict the list if roles reported. If no array ref is provided for types, will default to return only active roles.
=back
=head2 User Modification
@@ -6950,6 +8282,27 @@ all args are optional
=item *
+dumpstore($namespace,$udom,$uname,$regexp,$range) :
+dumps the complete (or key matching regexp) namespace into a hash
+($udom, $uname, $regexp, $range are optional) for a namespace that is
+normally &store()ed into
+
+$range should be either an integer '100' (give me the first 100
+ matching records)
+ or be two integers sperated by a - with no spaces
+ '30-50' (give me the 30th through the 50th matching
+ records)
+
+
+=item *
+
+putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :
+replaces a &store() version of data with a replacement set of data
+for a particular resource in a namespace passed in the $storehash hash
+reference
+
+=item *
+
tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that
works very similar to store/cstore, but all data is stored in a
temporary location and can be reset using tmpreset, $storehash should
@@ -6979,10 +8332,15 @@ namesp ($udom and $uname are optional)
=item *
-dump($namespace,$udom,$uname,$regexp) :
+dump($namespace,$udom,$uname,$regexp,$range) :
dumps the complete (or key matching regexp) namespace into a hash
-($udom, $uname and $regexp are optional)
+($udom, $uname, $regexp, $range are optional)
+$range should be either an integer '100' (give me the first 100
+ matching records)
+ or be two integers sperated by a - with no spaces
+ '30-50' (give me the 30th through the 50th matching
+ records)
=item *
inc($namespace,$store,$udom,$uname) : increments $store in $namespace.
@@ -6998,19 +8356,33 @@ put($namespace,$storehash,$udom,$uname)
=item *
-putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp
-keys used in storehash include version information (e.g., 1:$symb:message etc.) as
-used in records written by &store and retrieved by &restore. This function
-was created for use in editing discussion posts, without incrementing the
-version number included in the key for a particular post. The colon
-separated list of attribute names (e.g., the value associated with the key
-1:keys:$symb) is also generated and passed in the ampersand separated
-items sent to lonnet::reply().
+cput($namespace,$storehash,$udom,$uname) : critical put
+($udom and $uname are optional)
=item *
-cput($namespace,$storehash,$udom,$uname) : critical put
-($udom and $uname are optional)
+newput($namespace,$storehash,$udom,$uname) :
+
+Attempts to store the items in the $storehash, but only if they don't
+currently exist, if this succeeds you can be certain that you have
+successfully created a new key value pair in the $namespace db.
+
+
+Args:
+ $namespace: name of database to store values to
+ $storehash: hashref to store to the db
+ $udom: (optional) domain of user containing the db
+ $uname: (optional) name of user caontaining the db
+
+Returns:
+ 'ok' -> succeeded in storing all keys of $storehash
+ 'key_exists: ' -> failed to anything out of $storehash, as at
+ least already existed in the db (other
+ requested keys may also already exist)
+ 'error: ' -> unable to tie the DB or other erorr occured
+ 'con_lost' -> unable to contact request server
+ 'refused' -> action was not allowed by remote machine
+
=item *
@@ -7023,6 +8395,15 @@ reference filled in from namesp (encrypt
log($udom,$name,$home,$message) : write to permanent log for user; use
critical subroutine
+=item *
+
+get_dom($namespace,$storearr,$udomain) : returns hash with keys from array
+reference filled in from namespace found in domain level on primary domain server ($udomain is optional)
+
+=item *
+
+put_dom($namespace,$storehash,$udomain) : stores hash in namespace at domain level on primary domain server ($udomain is optional)
+
=back
=head2 Network Status Functions
@@ -7138,6 +8519,16 @@ getfile($file,$caller) : two cases - req
- returns the entire contents of a file or -1;
it properly subscribes to and replicates the file if neccessary.
+
+=item *
+
+stat_file($url) : $url is expected to be a /res/ or /uploaded/ style file
+ reference
+
+returns either a stat() list of data about the file or an empty list
+if the file doesn't exist or couldn't find out about it (connection
+problems or user unknown)
+
=item *
filelocation($dir,$file) : returns file system location of a file
@@ -7238,6 +8629,94 @@ removeuploadedurl(): convience function
Args:
url: a full /uploaded/... url to delete
+=item *
+
+get_portfile_permissions():
+ Args:
+ domain: domain of user or course contain the portfolio files
+ user: name of user or num of course contain the portfolio files
+ Returns:
+ hashref of a dump of the proper file_permissions.db
+
+
+=item *
+
+get_access_controls():
+
+Args:
+ current_permissions: the hash ref returned from get_portfile_permissions()
+ group: (optional) the group you want the files associated with
+ file: (optional) the file you want access info on
+
+Returns:
+ a hash (keys are file names) of hashes containing
+ keys are: path to file/file_name\0uniqueID:scope_end_start (see below)
+ values are XML containing access control settings (see below)
+
+Internal notes:
+
+ access controls are stored in file_permissions.db as key=value pairs.
+ key -> path to file/file_name\0uniqueID:scope_end_start
+ where scope -> public,guest,course,group,domains or users.
+ end -> UNIX time for end of access (0 -> no end date)
+ start -> UNIX time for start of access
+
+ value -> XML description of access control
+ (type =1 of: public,guest,course,group,domains,users">
+
+
+
+ for scope type = guest
+
+ for scope type = course or group
+
+
+
+
+
+
+
+
+ for scope type = domains
+
+ for scope type = users
+
+
+
+
+
+
+
+ Access data is also aggregated for each file in an additional key=value pair:
+ key -> path to file/file_name\0accesscontrol
+ value -> reference to hash
+ hash contains key = value pairs
+ where key = uniqueID:scope_end_start
+ value = UNIX time record was last updated
+
+ Used to improve speed of look-ups of access controls for each file.
+
+ Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.
+
+modify_access_controls():
+
+Modifies access controls for a portfolio file
+Args
+1. file name
+2. reference to hash of required changes,
+3. domain
+4. username
+ where domain,username are the domain of the portfolio owner
+ (either a user or a course)
+
+Returns:
+1. result of additions or updates ('ok' or 'error', with error message).
+2. result of deletions ('ok' or 'error', with error message).
+3. reference to hash of any new or updated access controls.
+4. reference to hash used to map incoming IDs to uniqueIDs assigned to control.
+ key = integer (inbound ID)
+ value = uniqueID
+
=back
=head2 HTTP Helper Routines