--- loncom/lonnet/perl/lonnet.pm 2011/12/05 01:14:21 1.1147
+++ loncom/lonnet/perl/lonnet.pm 2012/05/18 20:03:22 1.1170
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1147 2011/12/05 01:14:21 raeburn Exp $
+# $Id: lonnet.pm,v 1.1170 2012/05/18 20:03:22 droeschl Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -96,6 +96,8 @@ use Math::Random;
use File::MMagic;
use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;
+use LONCAPA::lonmetadata;
+use LONCAPA::Lond;
use File::Copy;
@@ -595,13 +597,21 @@ sub transfer_profile_to_env {
# ---------------------------------------------------- Check for valid session
sub check_for_valid_session {
- my ($r) = @_;
+ my ($r,$name) = @_;
my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
- my $lonid=$cookies{'lonID'};
+ if ($name eq '') {
+ $name = 'lonID';
+ }
+ my $lonid=$cookies{$name};
return undef if (!$lonid);
my $handle=&LONCAPA::clean_handle($lonid->value);
- my $lonidsdir=$r->dir_config('lonIDsDir');
+ my $lonidsdir;
+ if ($name eq 'lonDAV') {
+ $lonidsdir=$r->dir_config('lonDAVsessDir');
+ } else {
+ $lonidsdir=$r->dir_config('lonIDsDir');
+ }
return undef if (!-e "$lonidsdir/$handle.id");
my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
@@ -930,7 +940,7 @@ sub choose_server {
my %domconfhash = &Apache::loncommon::get_domainconf($udom);
my %servers = &get_servers($udom);
my $lowest_load = 30000;
- my ($login_host,$hostname,$portal_path);
+ my ($login_host,$hostname,$portal_path,$isredirect);
foreach my $lonhost (keys(%servers)) {
my $loginvia;
if ($checkloginvia) {
@@ -941,12 +951,14 @@ sub choose_server {
&compare_server_load($server, $login_host, $lowest_load);
if ($login_host eq $server) {
$portal_path = $path;
+ $isredirect = 1;
}
} else {
($login_host, $lowest_load) =
&compare_server_load($lonhost, $login_host, $lowest_load);
if ($login_host eq $lonhost) {
$portal_path = '';
+ $isredirect = '';
}
}
} else {
@@ -957,7 +969,7 @@ sub choose_server {
if ($login_host ne '') {
$hostname = &hostname($login_host);
}
- return ($login_host,$hostname,$portal_path);
+ return ($login_host,$hostname,$portal_path,$isredirect);
}
# --------------------------------------------- Try to change a user's password
@@ -1524,16 +1536,13 @@ sub idput {
# ------------------------------dump from db file owned by domainconfig user
sub dump_dom {
- my ($namespace,$udom,$regexp,$range)=@_;
- if (!$udom) {
- $udom=$env{'user.domain'};
- }
- my %returnhash;
- if ($udom) {
- my $uname = &get_domainconfiguser($udom);
- %returnhash = &dump($namespace,$udom,$uname,$regexp,$range);
- }
- return %returnhash;
+ my ($namespace, $udom, $regexp) = @_;
+
+ $udom ||= $env{'user.domain'};
+
+ return () unless $udom;
+
+ return &dump($namespace, $udom, &get_domainconfiguser($udom), $regexp);
}
# ------------------------------------------ get items from domain db files
@@ -2147,8 +2156,7 @@ sub getsection {
# If there is a role which has expired, return it.
#
$courseid = &courseid_to_courseurl($courseid);
- my $extra = &freeze_escape({'skipcheck' => 1});
- my %roleshash = &dump('roles',$udom,$unam,$courseid,undef,$extra);
+ my %roleshash = &dump('roles',$udom,$unam,$courseid);
foreach my $key (keys(%roleshash)) {
next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
my $section=$1;
@@ -2432,7 +2440,7 @@ sub repcopy {
$filename=~s/\/+/\//g;
my $londocroot = $perlvar{'lonDocRoot'};
if ($filename=~m{^\Q$londocroot/adm/\E}) { return 'ok'; }
- if ($filename=~m{^\Q$londocroot/lonUsers/\E}) { return 'ok'; }
+ if ($filename=~m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
if ($filename=~m{^\Q$londocroot/userfiles/\E} or
$filename=~m{^/*(uploaded|editupload)/}) {
return &repcopy_userfile($filename);
@@ -2799,7 +2807,7 @@ sub resizeImage {
# $resizewidth - width (pixels) to which to resize uploaded image
# $resizeheight - height (pixels) to which to resize uploaded image
# $mimetype - reference to scalar to accommodate mime type determined
-# from File::MMagic if $parser = parse.
+# from File::MMagic.
#
# output: url of file in userspace, or error: <message>
# or /adm/notfound.html if failure to upload occurse
@@ -2968,10 +2976,17 @@ sub finishuserfileupload {
}
}
}
+ if (($context eq 'coursedoc') || ($parser eq 'parse')) {
+ if (ref($mimetype)) {
+ if ($$mimetype eq '') {
+ my $mm = new File::MMagic;
+ my $type = $mm->checktype_filename($filepath.'/'.$file);
+ $$mimetype = $type;
+ }
+ }
+ }
if ($parser eq 'parse') {
- my $mm = new File::MMagic;
- my $type = $mm->checktype_filename($filepath.'/'.$file);
- if ($type eq 'text/html') {
+ if ((ref($mimetype)) && ($$mimetype eq 'text/html')) {
my $parse_result = &extract_embedded_items($filepath.'/'.$file,
$allfiles,$codebase);
unless ($parse_result eq 'ok') {
@@ -2979,9 +2994,6 @@ sub finishuserfileupload {
' for embedded media: '.$parse_result);
}
}
- if (ref($mimetype)) {
- $$mimetype = $type;
- }
}
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
my $input = $filepath.'/'.$file;
@@ -3018,6 +3030,7 @@ sub finishuserfileupload {
sub extract_embedded_items {
my ($fullpath,$allfiles,$codebase,$content) = @_;
my @state = ();
+ my (%lastids,%related,%shockwave,%flashvars);
my %javafiles = (
codebase => '',
code => '',
@@ -3047,10 +3060,30 @@ sub extract_embedded_items {
&add_filetype($allfiles,$attr->{'href'},'href');
}
if (lc($tagname) eq 'script') {
+ my $src;
if ($attr->{'archive'} =~ /\.jar$/i) {
&add_filetype($allfiles,$attr->{'archive'},'archive');
} else {
- &add_filetype($allfiles,$attr->{'src'},'src');
+ if ($attr->{'src'} ne '') {
+ $src = $attr->{'src'};
+ &add_filetype($allfiles,$src,'src');
+ }
+ }
+ my $text = $p->get_trimmed_text();
+ if ($text =~ /\Qswfobject.registerObject(\E([^\)]+)\)/) {
+ my @swfargs = split(/,/,$1);
+ foreach my $item (@swfargs) {
+ $item =~ s/["']//g;
+ $item =~ s/^\s+//;
+ $item =~ s/\s+$//;
+ }
+ if (($swfargs[0] ne'') && ($swfargs[2] ne '')) {
+ if (ref($related{$swfargs[0]}) eq 'ARRAY') {
+ push(@{$related{$swfargs[0]}},$swfargs[2]);
+ } else {
+ $related{$swfargs[0]} = [$swfargs[2]];
+ }
+ }
}
}
if (lc($tagname) eq 'link') {
@@ -3063,6 +3096,9 @@ sub extract_embedded_items {
foreach my $item (keys(%javafiles)) {
$javafiles{$item} = '';
}
+ if ((lc($tagname) eq 'object') && (lc($state[-2]) ne 'object')) {
+ $lastids{lc($tagname)} = $attr->{'id'};
+ }
}
if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {
my $name = lc($attr->{'name'});
@@ -3072,12 +3108,22 @@ sub extract_embedded_items {
last;
}
}
+ my $pathfrom;
foreach my $item (keys(%mediafiles)) {
if ($name eq $item) {
- &add_filetype($allfiles, $attr->{'value'}, 'value');
+ $pathfrom = $attr->{'value'};
+ $shockwave{$lastids{lc($state[-2])}} = $pathfrom;
+ &add_filetype($allfiles,$pathfrom,$name);
last;
}
}
+ if ($name eq 'flashvars') {
+ $flashvars{$lastids{lc($state[-2])}} = $attr->{'value'};
+ }
+ if ($pathfrom ne '') {
+ &embedded_dependency($allfiles,\%related,$lastids{lc($state[-2])},
+ $pathfrom);
+ }
}
if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {
foreach my $item (keys(%javafiles)) {
@@ -3092,7 +3138,16 @@ sub extract_embedded_items {
last;
}
}
+ if (lc($tagname) eq 'embed') {
+ if (($attr->{'name'} ne '') && ($attr->{'src'} ne '')) {
+ &embedded_dependency($allfiles,\%related,$attr->{'name'},
+ $attr->{'src'});
+ }
+ }
}
+ if ($t->[4] =~ m{/>$}) {
+ pop(@state);
+ }
} elsif ($t->[0] eq 'E') {
my ($tagname) = ($t->[1]);
if ($javafiles{'codebase'} ne '') {
@@ -3112,6 +3167,23 @@ sub extract_embedded_items {
pop @state;
}
}
+ foreach my $id (sort(keys(%flashvars))) {
+ if ($shockwave{$id} ne '') {
+ my @pairs = split(/\&/,$flashvars{$id});
+ foreach my $pair (@pairs) {
+ my ($key,$value) = split(/\=/,$pair);
+ if ($key eq 'thumb') {
+ &add_filetype($allfiles,$value,$key);
+ } elsif ($key eq 'content') {
+ my ($path) = ($shockwave{$id} =~ m{^(.+/)[^/]+$});
+ my ($ext) = ($value =~ /\.([^.]+)$/);
+ if ($ext ne '') {
+ &add_filetype($allfiles,$path.$value,$ext);
+ }
+ }
+ }
+ }
+ }
return 'ok';
}
@@ -3126,6 +3198,21 @@ sub add_filetype {
}
}
+sub embedded_dependency {
+ my ($allfiles,$related,$identifier,$pathfrom) = @_;
+ if ((ref($allfiles) eq 'HASH') && (ref($related) eq 'HASH')) {
+ if (($identifier ne '') &&
+ (ref($related->{$identifier}) eq 'ARRAY') &&
+ ($pathfrom ne '')) {
+ my ($path) = ($pathfrom =~ m{^(.+/)[^/]+$});
+ foreach my $dep (@{$related->{$identifier}}) {
+ &add_filetype($allfiles,$path.$dep,'object');
+ }
+ }
+ }
+ return;
+}
+
sub removeuploadedurl {
my ($url)=@_;
my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
@@ -3252,15 +3339,10 @@ sub flushcourselogs {
my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);
if ($result eq 'ok') {
delete $accesshash{$entry};
- } elsif ($result eq 'unknown_cmd') {
- # Target server has old code running on it.
- my %temphash=($entry => $value);
- if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
- delete $accesshash{$entry};
- }
}
} else {
my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});
+ if (($dom eq 'uploaded') || ($dom eq 'adm')) { next; }
my %temphash=($entry => $accesshash{$entry});
if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
delete $accesshash{$entry};
@@ -3371,7 +3453,13 @@ sub countacc {
my $url=&declutter(shift);
return if (! defined($url) || $url eq '');
unless ($env{'request.course.id'}) { return ''; }
+#
+# Mark that this url was used in this course
+#
$accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1;
+#
+# Increase the access count for this resource in this child process
+#
my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
$accesshash{$key}++;
}
@@ -3383,31 +3471,37 @@ sub linklog {
$accesshash{$from.'___'.$to.'___comefrom'}=1;
$accesshash{$to.'___'.$from.'___goto'}=1;
}
+
+sub statslog {
+ my ($symb,$part,$users,$av_attempts,$degdiff)=@_;
+ if ($users<2) { return; }
+ my %dynstore=&LONCAPA::lonmetadata::dynamic_metadata_storage({
+ 'course' => $env{'request.course.id'},
+ 'sections' => '"all"',
+ 'num_students' => $users,
+ 'part' => $part,
+ 'symb' => $symb,
+ 'mean_tries' => $av_attempts,
+ 'deg_of_diff' => $degdiff});
+ foreach my $key (keys(%dynstore)) {
+ $accesshash{$key}=$dynstore{$key};
+ }
+}
sub userrolelog {
my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
- if (($trole=~/^ca/) || ($trole=~/^aa/) ||
- ($trole=~/^in/) || ($trole=~/^cc/) ||
- ($trole=~/^ep/) || ($trole=~/^cr/) ||
- ($trole=~/^ta/) || ($trole=~/^co/)) {
+ if ( $trole =~ /^(ca|aa|in|cc|ep|cr|ta|co)/ ) {
my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
$userrolehash
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
=$tend.':'.$tstart;
}
- if (($env{'request.role'} =~ /dc\./) &&
- (($trole=~/^au/) || ($trole=~/^in/) ||
- ($trole=~/^cc/) || ($trole=~/^ep/) ||
- ($trole=~/^cr/) || ($trole=~/^ta/) ||
- ($trole=~/^co/))) {
+ if ($env{'request.role'} =~ /dc\./ && $trole =~ /^(au|in|cc|ep|cr|ta|co)/) {
$userrolehash
{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
=$tend.':'.$tstart;
}
- if (($trole=~/^dc/) || ($trole=~/^ad/) ||
- ($trole=~/^li/) || ($trole=~/^li/) ||
- ($trole=~/^au/) || ($trole=~/^dg/) ||
- ($trole=~/^sc/)) {
+ if ($trole =~ /^(dc|ad|li|au|dg|sc)/ ) {
my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
$domainrolehash
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
@@ -3516,8 +3610,7 @@ sub get_my_roles {
unless (defined($udom)) { $udom=$env{'user.domain'}; }
my (%dumphash,%nothide);
if ($context eq 'userroles') {
- my $extra = &freeze_escape({'skipcheck' => 1});
- %dumphash = &dump('roles',$udom,$uname,'.',undef,$extra);
+ %dumphash = &dump('roles',$udom,$uname);
} else {
%dumphash=
&dump('nohist_userroles',$udom,$uname);
@@ -3538,6 +3631,7 @@ sub get_my_roles {
foreach my $entry (keys(%dumphash)) {
my ($role,$tend,$tstart);
if ($context eq 'userroles') {
+ next if ($entry =~ /^rolesdef/);
($role,$tend,$tstart)=split(/_/,$dumphash{$entry});
} else {
($tend,$tstart)=split(/\:/,$dumphash{$entry});
@@ -3851,11 +3945,34 @@ sub get_domain_roles {
# ----------------------------------------------------------- Interval timing
+{
+# Caches needed for speedup of navmaps
+# We don't want to cache this for very long at all (5 seconds at most)
+#
+# The user for whom we cache
+my $cachedkey='';
+# The cached times for this user
+my %cachedtimes=();
+# When this was last done
+my $cachedtime=();
+
+sub load_all_first_access {
+ my ($uname,$udom)=@_;
+ if (($cachedkey eq $uname.':'.$udom) &&
+ (abs($cachedtime-time)<5)) {
+ return;
+ }
+ $cachedtime=time;
+ $cachedkey=$uname.':'.$udom;
+ %cachedtimes=&dump('firstaccesstimes',$udom,$uname);
+}
+
sub get_first_access {
- my ($type,$argsymb)=@_;
+ my ($type,$argsymb,$argmap)=@_;
my ($symb,$courseid,$udom,$uname)=&whichuser();
if ($argsymb) { $symb=$argsymb; }
my ($map,$id,$res)=&decode_symb($symb);
+ if ($argmap) { $map = $argmap; }
if ($type eq 'course') {
$res='course';
} elsif ($type eq 'map') {
@@ -3863,12 +3980,12 @@ sub get_first_access {
} else {
$res=$symb;
}
- my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname);
- return $times{"$courseid\0$res"};
+ &load_all_first_access($uname,$udom);
+ return $cachedtimes{"$courseid\0$res"};
}
sub set_first_access {
- my ($type)=@_;
+ my ($type,$interval)=@_;
my ($symb,$courseid,$udom,$uname)=&whichuser();
my ($map,$id,$res)=&decode_symb($symb);
if ($type eq 'course') {
@@ -3878,13 +3995,27 @@ sub set_first_access {
} else {
$res=$symb;
}
- my $firstaccess=&get_first_access($type,$symb);
+ $cachedkey='';
+ my $firstaccess=&get_first_access($type,$symb,$map);
if (!$firstaccess) {
- return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);
+ my $start = time;
+ my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start},
+ $udom,$uname);
+ if ($putres eq 'ok') {
+ &put('timerinterval',{"$courseid\0$res"=>$interval},
+ $udom,$uname);
+ &appenv(
+ {
+ 'course.'.$courseid.'.firstaccess.'.$res => $start,
+ 'course.'.$courseid.'.timerinterval.'.$res => $interval,
+ }
+ );
+ }
+ return $putres;
}
return 'already_set';
}
-
+}
# --------------------------------------------- Set Expire Date for Spreadsheet
sub expirespread {
@@ -4472,95 +4603,127 @@ sub update_released_required {
sub privileged {
my ($username,$domain)=@_;
- my $rolesdump=&reply("dump:$domain:$username:roles",
- &homeserver($username,$domain));
- if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||
- ($rolesdump =~ /^error:/)) {
- return 0;
- }
- my $now=time;
- if ($rolesdump ne '') {
- 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')) {
- my $active=1;
- if ($tend) {
- if ($tend<$now) { $active=0; }
- }
- if ($tstart) {
- if ($tstart>$now) { $active=0; }
- }
- if ($active) { return 1; }
- }
- }
+
+ my %rolesdump = &dump("roles", $domain, $username) or return 0;
+ my $now = time;
+
+ for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {
+ my ($trole, $tend, $tstart) = split(/_/, $role);
+ if (($trole eq 'dc') || ($trole eq 'su')) {
+ return 1 unless ($tend && $tend < $now)
+ or ($tstart && $tstart > $now);
+ }
}
- }
+
return 0;
}
# -------------------------------------------------------- Get user privileges
sub rolesinit {
- my ($domain,$username,$authhost)=@_;
- my $now=time;
- my %userroles = ('user.login.time' => $now);
- my $extra = &freeze_escape({'skipcheck' => 1});
- my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost);
- if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||
- ($rolesdump =~ /^error:/)) {
- return \%userroles;
+ my ($domain, $username) = @_;
+ my %userroles = ('user.login.time' => time);
+ my %rolesdump = &dump("roles", $domain, $username) or return \%userroles;
+
+ # firstaccess and timerinterval are related to timed maps/resources.
+ # also, blocking can be triggered by an activating timer
+ # it's saved in the user's %env.
+ my %firstaccess = &dump('firstaccesstimes', $domain, $username);
+ my %timerinterval = &dump('timerinterval', $domain, $username);
+ my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,
+ %timerintchk, %timerintenv);
+
+ foreach my $key (keys(%firstaccess)) {
+ my ($cid, $rest) = split(/\0/, $key);
+ $coursetimerstarts{$cid}{$rest} = $firstaccess{$key};
+ }
+
+ foreach my $key (keys(%timerinterval)) {
+ my ($cid,$rest) = split(/\0/,$key);
+ $coursetimerintervals{$cid}{$rest} = $timerinterval{$key};
}
+
my %allroles=();
- my %allgroups=();
+ my %allgroups=();
- if ($rolesdump ne '') {
- 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/$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;
- }
- } elsif ($role =~ m|^gr/|) {
- ($trole,$tend,$tstart) = split(/_/,$role);
- next if ($tstart eq '-1');
- ($trole,$group_privs) = split(/\//,$trole);
- $group_privs = &unescape($group_privs);
- } else {
- ($trole,$tend,$tstart)=split(/_/,$role);
- }
- 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 '')) {
- my $spec=$trole.'.'.$area;
- my ($tdummy,$tdomain,$trest)=split(/\//,$area);
- if ($trole =~ /^cr\//) {
- &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
- } elsif ($trole eq 'gr') {
- &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
- } else {
- &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
- }
+ for my $area (grep { ! /^rolesdef_/ } keys %rolesdump) {
+ my $role = $rolesdump{$area};
+ $area =~ s/\_\w\w$//;
+
+ my ($trole, $tend, $tstart, $group_privs);
+
+ if ($role =~ /^cr/) {
+ # Custom role, defined by a user
+ # e.g., user.role.cr/msu/smith/mynewrole
+ if ($role =~ m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
+ $trole = $1;
+ ($tend, $tstart) = split('_', $2);
+ } else {
+ $trole = $role;
}
- }
+ } elsif ($role =~ m|^gr/|) {
+ # Role of member in a group, defined within a course/community
+ # e.g., user.role.gr/msu/04935610a19ee4a5fmsul1/leopards
+ ($trole, $tend, $tstart) = split(/_/, $role);
+ next if $tstart eq '-1';
+ ($trole, $group_privs) = split(/\//, $trole);
+ $group_privs = &unescape($group_privs);
+ } else {
+ # Just a normal role, defined in roles.tab
+ ($trole, $tend, $tstart) = split(/_/,$role);
+ }
+
+ my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
+ $username);
+ @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
+
+ # role expired or not available yet?
+ $trole = '' if ($tend != 0 && $tend < $userroles{'user.login.time'}) or
+ ($tstart != 0 && $tstart > $userroles{'user.login.time'});
+
+ next if $area eq '' or $trole eq '';
+
+ my $spec = "$trole.$area";
+ my ($tdummy, $tdomain, $trest) = split(/\//, $area);
+
+ if ($trole =~ /^cr\//) {
+ # Custom role, defined by a user
+ &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
+ } elsif ($trole eq 'gr') {
+ # Role of a member in a group, defined within a course/community
+ &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
+ next;
+ } else {
+ # Normal role, defined in roles.tab
+ &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
+ }
+
+ my $cid = $tdomain.'_'.$trest;
+ unless ($firstaccchk{$cid}) {
+ if (ref($coursetimerstarts{$cid}) eq 'HASH') {
+ foreach my $item (keys(%{$coursetimerstarts{$cid}})) {
+ $firstaccenv{'course.'.$cid.'.firstaccess.'.$item} =
+ $coursetimerstarts{$cid}{$item};
+ }
+ }
+ $firstaccchk{$cid} = 1;
+ }
+ unless ($timerintchk{$cid}) {
+ if (ref($coursetimerintervals{$cid}) eq 'HASH') {
+ foreach my $item (keys(%{$coursetimerintervals{$cid}})) {
+ $timerintenv{'course.'.$cid.'.timerinterval.'.$item} =
+ $coursetimerintervals{$cid}{$item};
+ }
+ }
+ $timerintchk{$cid} = 1;
}
- my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups);
- $userroles{'user.adv'} = $adv;
- $userroles{'user.author'} = $author;
- $env{'user.adv'}=$adv;
}
- return \%userroles;
+
+ @userroles{'user.author', 'user.adv'} = &set_userprivs(\%userroles,
+ \%allroles, \%allgroups);
+ $env{'user.adv'} = $userroles{'user.adv'};
+
+ return (\%userroles,\%firstaccenv,\%timerintenv);
}
sub set_arearole {
@@ -4895,16 +5058,17 @@ sub del {
# -------------------------------------------------------------- dump interface
sub dump {
- my ($namespace,$udomain,$uname,$regexp,$range,$extra)=@_;
+ 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:$extra",$uhome);
+ my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
my @pairs=split(/\&/,$rep);
my %returnhash=();
if (!($rep =~ /^error/ )) {
@@ -5941,7 +6105,12 @@ sub allowed {
if ($match) {
if ($env{'user.priv.'.$env{'request.role'}.'./'}
=~/\Q$priv\E\&([^\:]*)/) {
- $thisallowed.=$1;
+ my @blockers = &has_comm_blocking($priv,$symb,$uri);
+ if (@blockers > 0) {
+ $thisallowed = 'B';
+ } else {
+ $thisallowed.=$1;
+ }
}
} else {
my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
@@ -5952,7 +6121,12 @@ sub allowed {
$refuri=&declutter($refuri);
my ($match) = &is_on_map($refuri);
if ($match) {
- $thisallowed='F';
+ my @blockers = &has_comm_blocking($priv,$symb,$refuri);
+ if (@blockers > 0) {
+ $thisallowed = 'B';
+ } else {
+ $thisallowed='F';
+ }
}
}
}
@@ -6004,7 +6178,17 @@ sub allowed {
$statecond=$cond;
if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
=~/\Q$priv\E\&([^\:]*)/) {
- $thisallowed.=$1;
+ my $value = $1;
+ if ($priv eq 'bre') {
+ my @blockers = &has_comm_blocking($priv,$symb,$uri);
+ if (@blockers > 0) {
+ $thisallowed = 'B';
+ } else {
+ $thisallowed.=$value;
+ }
+ } else {
+ $thisallowed.=$value;
+ }
$checkreferer=0;
}
}
@@ -6032,7 +6216,17 @@ sub allowed {
my $refstatecond=$cond;
if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
=~/\Q$priv\E\&([^\:]*)/) {
- $thisallowed.=$1;
+ my $value = $1;
+ if ($priv eq 'bre') {
+ my @blockers = &has_comm_blocking($priv,$symb,$refuri);
+ if (@blockers > 0) {
+ $thisallowed = 'B';
+ } else {
+ $thisallowed.=$value;
+ }
+ } else {
+ $thisallowed.=$value;
+ }
$uri=$refuri;
$statecond=$refstatecond;
}
@@ -6191,6 +6385,164 @@ sub allowed {
}
return 'F';
}
+
+sub get_comm_blocks {
+ my ($cdom,$cnum) = @_;
+ if ($cdom eq '' || $cnum eq '') {
+ return unless ($env{'request.course.id'});
+ $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+ $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+ }
+ my %commblocks;
+ my $hashid=$cdom.'_'.$cnum;
+ my ($blocksref,$cached)=&is_cached_new('comm_block',$hashid);
+ if ((defined($cached)) && (ref($blocksref) eq 'HASH')) {
+ %commblocks = %{$blocksref};
+ } else {
+ %commblocks = &Apache::lonnet::dump('comm_block',$cdom,$cnum);
+ my $cachetime = 600;
+ &do_cache_new('comm_block',$hashid,\%commblocks,$cachetime);
+ }
+ return %commblocks;
+}
+
+sub has_comm_blocking {
+ my ($priv,$symb,$uri,$blocks) = @_;
+ return unless ($env{'request.course.id'});
+ return unless ($priv eq 'bre');
+ return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
+ my %commblocks;
+ if (ref($blocks) eq 'HASH') {
+ %commblocks = %{$blocks};
+ } else {
+ %commblocks = &get_comm_blocks();
+ }
+ return unless (keys(%commblocks) > 0);
+ if (!$symb) { $symb=&symbread($uri,1); }
+ my ($map,$resid,undef)=&decode_symb($symb);
+ my %tocheck = (
+ maps => $map,
+ resources => $symb,
+ );
+ my @blockers;
+ my $now = time;
+ my $navmap = Apache::lonnavmaps::navmap->new();
+ foreach my $block (keys(%commblocks)) {
+ if ($block =~ /^(\d+)____(\d+)$/) {
+ my ($start,$end) = ($1,$2);
+ if ($start <= $now && $end >= $now) {
+ if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
+ if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
+ if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {
+ if ($commblocks{$block}{'blocks'}{'docs'}{'maps'}{$map}) {
+ unless (grep(/^\Q$block\E$/,@blockers)) {
+ push(@blockers,$block);
+ }
+ }
+ }
+ if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
+ if ($commblocks{$block}{'blocks'}{'docs'}{'resources'}{$symb}) {
+ unless (grep(/^\Q$block\E$/,@blockers)) {
+ push(@blockers,$block);
+ }
+ }
+ }
+ }
+ }
+ }
+ } elsif ($block =~ /^firstaccess____(.+)$/) {
+ my $item = $1;
+ my @to_test;
+ if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
+ if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
+ my $check_interval;
+ if (&check_docs_block($commblocks{$block}{'blocks'}{'docs'},\%tocheck)) {
+ my @interval;
+ my $type = 'map';
+ if ($item eq 'course') {
+ $type = 'course';
+ @interval=&EXT("resource.0.interval");
+ } else {
+ if ($item =~ /___\d+___/) {
+ $type = 'resource';
+ @interval=&EXT("resource.0.interval",$item);
+ if (ref($navmap)) {
+ my $res = $navmap->getBySymb($item);
+ push(@to_test,$res);
+ }
+ } else {
+ my $mapsymb = &symbread($item,1);
+ if ($mapsymb) {
+ if (ref($navmap)) {
+ my $mapres = $navmap->getBySymb($mapsymb);
+ @to_test = $mapres->retrieveResources($mapres,undef,0,1);
+ foreach my $res (@to_test) {
+ my $symb = $res->symb();
+ next if ($symb eq $mapsymb);
+ if ($symb ne '') {
+ @interval=&EXT("resource.0.interval",$symb);
+ last;
+ }
+ }
+ }
+ }
+ }
+ }
+ if ($interval[0] =~ /\d+/) {
+ my $first_access;
+ if ($type eq 'resource') {
+ $first_access=&get_first_access($interval[1],$item);
+ } elsif ($type eq 'map') {
+ $first_access=&get_first_access($interval[1],undef,$item);
+ } else {
+ $first_access=&get_first_access($interval[1]);
+ }
+ if ($first_access) {
+ my $timesup = $first_access+$interval[0];
+ if ($timesup > $now) {
+ foreach my $res (@to_test) {
+ if ($res->is_problem()) {
+ if ($res->completable()) {
+ unless (grep(/^\Q$block\E$/,@blockers)) {
+ push(@blockers,$block);
+ }
+ last;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ return @blockers;
+}
+
+sub check_docs_block {
+ my ($docsblock,$tocheck) =@_;
+ if ((ref($docsblock) ne 'HASH') || (ref($tocheck) ne 'HASH')) {
+ return;
+ }
+ if (ref($docsblock->{'maps'}) eq 'HASH') {
+ if ($tocheck->{'maps'}) {
+ if ($docsblock->{'maps'}{$tocheck->{'maps'}}) {
+ return 1;
+ }
+ }
+ }
+ if (ref($docsblock->{'resources'}) eq 'HASH') {
+ if ($tocheck->{'resources'}) {
+ if ($docsblock->{'resources'}{$tocheck->{'resources'}}) {
+ return 1;
+ }
+ }
+ }
+ return;
+}
+
#
# Removes the versino from a URI and
# splits it in to its filename and path to the filename.
@@ -6926,8 +7278,7 @@ sub get_users_groups {
} else {
$grouplist = '';
my $courseurl = &courseid_to_courseurl($courseid);
- my $extra = &freeze_escape({'skipcheck' => 1});
- my %roleshash = &dump('roles',$udom,$uname,$courseurl,undef,$extra);
+ my %roleshash = &dump('roles',$udom,$uname,$courseurl);
my $access_end = $env{'course.'.$courseid.
'.default_enrollment_end_date'};
my $now = time;
@@ -7515,14 +7866,16 @@ sub modify_student_enrollment {
$uid = $tmp{'id'} if (!defined($uid) || $uid eq '');
}
my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
+ my $user = "$uname:$udom";
+ my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);
my $reply=cput('classlist',
- {"$uname:$udom" =>
+ {$user =>
join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
$cdom,$cnum);
- unless (($reply eq 'ok') || ($reply eq 'delayed')) {
+ if (($reply eq 'ok') || ($reply eq 'delayed')) {
+ &devalidate_getsection_cache($udom,$uname,$cid);
+ } else {
return 'error: '.$reply;
- } else {
- &devalidate_getsection_cache($udom,$uname,$cid);
}
# Add student role to user
my $uurl='/'.$cid;
@@ -7530,7 +7883,16 @@ sub modify_student_enrollment {
if ($usec) {
$uurl.='/'.$usec;
}
- return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll,$context);
+ my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,
+ $selfenroll,$context);
+ if ($result ne 'ok') {
+ if ($old_entry{$user} ne '') {
+ $reply = &cput('classlist',\%old_entry,$cdom,$cnum);
+ } else {
+ $reply = &del('classlist',[$user],$cdom,$cnum);
+ }
+ }
+ return $result;
}
sub format_name {
@@ -7729,13 +8091,16 @@ sub generate_coursenum {
}
sub is_course {
- my ($cdom,$cnum) = @_;
- my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
- undef,'.');
- if (exists($courses{$cdom.'_'.$cnum})) {
- return 1;
- }
- return 0;
+ my ($cdom, $cnum) = scalar(@_) == 1 ?
+ ($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_;
+
+ return unless $cdom and $cnum;
+
+ my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,
+ '.');
+
+ return unless exists($courses{$cdom.'_'.$cnum});
+ return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
}
sub store_userdata {
@@ -9355,6 +9720,10 @@ sub gettitle {
}
$title=~s/\&colon\;/\:/gs;
if ($title) {
+# Remember both $symb and $title for dynamic metadata
+ $accesshash{$symb.'___crstitle'}=$title;
+ $accesshash{&declutter($map).'___'.&declutter($url).'___usage'}=time;
+# Cache this title and then return it
return &do_cache_new('title',$key,$title,600);
}
$urlsymb=$url;
@@ -9387,6 +9756,49 @@ sub get_slot {
}
return $slotinfo{$which};
}
+
+sub get_reservable_slots {
+ my ($cnum,$cdom,$uname,$udom) = @_;
+ my $now = time;
+ my $reservable_info;
+ my $key=join("\0",'reservableslots',$cdom,$cnum,$uname,$udom);
+ if (exists($remembered{$key})) {
+ $reservable_info = $remembered{$key};
+ } else {
+ my %resv;
+ ($resv{'now_order'},$resv{'now'},$resv{'future_order'},$resv{'future'}) =
+ &Apache::loncommon::get_future_slots($cnum,$cdom,$now);
+ $reservable_info = \%resv;
+ $remembered{$key} = $reservable_info;
+ }
+ return $reservable_info;
+}
+
+sub get_course_slots {
+ my ($cnum,$cdom) = @_;
+ my $hashid=$cnum.':'.$cdom;
+ my ($result,$cached) = &Apache::lonnet::is_cached_new('allslots',$hashid);
+ if (defined($cached)) {
+ if (ref($result) eq 'HASH') {
+ return %{$result};
+ }
+ } else {
+ my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum);
+ my ($tmp) = keys(%slots);
+ if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
+ &Apache::lonnet::do_cache_new('allslots',$hashid,\%slots,600);
+ return %slots;
+ }
+ }
+ return;
+}
+
+sub devalidate_slots_cache {
+ my ($cnum,$cdom)=@_;
+ my $hashid=$cnum.':'.$cdom;
+ &devalidate_cache_new('allslots',$hashid);
+}
+
# ------------------------------------------------- Update symbolic store links
sub symblist {
@@ -10091,7 +10503,7 @@ sub repcopy_userfile {
my ($file)=@_;
my $londocroot = $perlvar{'lonDocRoot'};
if ($file =~ m{^/*(uploaded|editupload)/}) { $file=&filelocation("",$file); }
- if ($file =~ m{^\Q$londocroot/lonUsers/\E}) { return 'ok'; }
+ if ($file =~ m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
my ($cdom,$cnum,$filename) =
($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
my $uri="/uploaded/$cdom/$cnum/$filename";
@@ -11266,7 +11678,8 @@ B<idput($udom,%ids)>: store away a list
=item *
X<rolesinit()>
-B<rolesinit($udom,$username,$authhost)>: get user privileges
+B<rolesinit($udom,$username)>: get user privileges.
+returns user role, first access and timer interval hashes
=item *
X<getsection()>
@@ -11559,6 +11972,19 @@ createcourse($udom,$description,$url,$co
generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community).
+=item *
+
+is_course($courseid), is_course($cdom, $cnum)
+
+Accepts either a combined $courseid (in the form of domain_courseid) or the
+two component version $cdom, $cnum. It checks if the specified course exists.
+
+Returns:
+ undef if the course doesn't exist, otherwise
+ in scalar context the combined courseid.
+ in list context the two components of the course identifier, domain and
+ courseid.
+
=back
=head2 Resource Subroutines