--- loncom/lonnet/perl/lonnet.pm 2015/04/15 04:11:17 1.1282 +++ loncom/lonnet/perl/lonnet.pm 2015/06/16 20:24:59 1.1289 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1282 2015/04/15 04:11:17 raeburn Exp $ +# $Id: lonnet.pm,v 1.1289 2015/06/16 20:24:59 damieng Exp $ # # Copyright Michigan State University Board of Trustees # @@ -92,7 +92,7 @@ use GDBM_File; use HTML::LCParser; use Fcntl qw(:flock); use Storable qw(thaw nfreeze); -use Time::HiRes qw( gettimeofday tv_interval ); +use Time::HiRes qw( sleep gettimeofday tv_interval ); use Cache::Memcached; use Digest::MD5; use Math::Random; @@ -105,7 +105,7 @@ use LONCAPA::Lond; use File::Copy; my $readit; -my $max_connection_retries = 10; # Or some such value. +my $max_connection_retries = 20; # Or some such value. require Exporter; @@ -375,7 +375,7 @@ sub subreply { my $lockfile=$peerfile.".lock"; while (-e $lockfile) { # Need to wait for the lockfile to disappear. - sleep(1); + sleep(0.1); } # At this point, either a loncnew parent is listening or an old lonc # or loncnew child is listening so we can connect or everything's dead. @@ -393,7 +393,7 @@ sub subreply { } else { &create_connection(&hostname($server),$server); } - sleep(1); # Try again later if failed connection. + sleep(0.1); # Try again later if failed connection. } my $answer; if ($client) { @@ -486,7 +486,7 @@ sub critical { close($dfh); } } - sleep 2; + sleep 1; my $wcmd=''; { my $dfh; @@ -2101,6 +2101,16 @@ sub get_domain_defaults { } } } + if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') { + if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') { + my @clonecodes = @{$domconfig{'coursedefaults'}{'canclone'}{'instcode'}}; + if (@clonecodes) { + $domdefaults{'canclone'} = join('+',@clonecodes); + } + } + } elsif ($domconfig{'coursedefaults'}{'canclone'}) { + $domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'}; + } } if (ref($domconfig{'usersessions'}) eq 'HASH') { if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') { @@ -4270,7 +4280,7 @@ sub courseiddump { $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone, $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner, - $hasuniquecode)=@_; + $hasuniquecode,$reqcrsdom,$reqinstcode)=@_; my $as_hash = 1; my %returnhash; if (!$domfilter) { $domfilter=''; } @@ -4293,7 +4303,8 @@ sub courseiddump { &escape($catfilter), $showhidden, $caller, &escape($cloner), &escape($cc_clone), $cloneonly, &escape($createdbefore), &escape($createdafter), - &escape($creationcontext), $domcloner, $hasuniquecode))); + &escape($creationcontext),$domcloner,$hasuniquecode, + $reqcrsdom,&escape($reqinstcode)))); } else { $rep = &reply('courseiddump:'.&host_domain($tryserver).':'. $sincefilter.':'.&escape($descfilter).':'. @@ -4304,8 +4315,8 @@ sub courseiddump { $showhidden.':'.$caller.':'.&escape($cloner).':'. &escape($cc_clone).':'.$cloneonly.':'. &escape($createdbefore).':'.&escape($createdafter).':'. - &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode, - $tryserver); + &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode. + ':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver); } my @pairs=split(/\&/,$rep); @@ -7332,7 +7343,7 @@ sub get_commblock_resources { if ($timesup > $now) { my $activeblock; foreach my $res (@to_test) { - if ($res->completable()) { + if ($res->answerable()) { $activeblock = 1; last; } @@ -7667,7 +7678,7 @@ sub get_query_reply { my $replyfile=LONCAPA::tempdir().$queryid; my $reply=''; for (1..100) { - sleep 2; + sleep(0.2); if (-e $replyfile.'.end') { if (open(my $fh,$replyfile)) { $reply = join('',<$fh>); @@ -8090,6 +8101,80 @@ sub auto_crsreq_update { return \%crsreqresponse; } +sub check_instcode_cloning { + my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_; + unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) { + return; + } + my $canclone; + if (@{$code_order} > 0) { + my $instcoderegexp ='^'; + my @clonecodes = split(/\&/,$cloner); + foreach my $item (@{$code_order}) { + if (grep(/^\Q$item\E=/,@clonecodes)) { + foreach my $pair (@clonecodes) { + my ($key,$val) = split(/\=/,$pair,2); + $val = &unescape($val); + if ($key eq $item) { + $instcoderegexp .= '('.$val.')'; + last; + } + } + } else { + $instcoderegexp .= $codedefaults->{$item}; + } + } + $instcoderegexp .= '$'; + my (@from,@to); + eval { + (@from) = ($clonefromcode =~ /$instcoderegexp/); + (@to) = ($clonetocode =~ /$instcoderegexp/); + }; + if ((@from > 0) && (@to > 0)) { + my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to); + if (!@diffs) { + $canclone = 1; + } + } + } + return $canclone; +} + +sub default_instcode_cloning { + my ($clonedom,$domdefclone,$clonefromcode,$clonetocode,$codedefaultsref,$codeorderref) = @_; + my (%codedefaults,@code_order,$canclone); + if ((ref($codedefaultsref) eq 'HASH') && (ref($codeorderref) eq 'ARRAY')) { + %codedefaults = %{$codedefaultsref}; + @code_order = @{$codeorderref}; + } elsif ($clonedom) { + &auto_instcode_defaults($clonedom,\%codedefaults,\@code_order); + } + if (($domdefclone) && (@code_order)) { + my @clonecodes = split(/\+/,$domdefclone); + my $instcoderegexp ='^'; + foreach my $item (@code_order) { + if (grep(/^\Q$item\E$/,@clonecodes)) { + $instcoderegexp .= '('.$codedefaults{$item}.')'; + } else { + $instcoderegexp .= $codedefaults{$item}; + } + } + $instcoderegexp .= '$'; + my (@from,@to); + eval { + (@from) = ($clonefromcode =~ /$instcoderegexp/); + (@to) = ($clonetocode =~ /$instcoderegexp/); + }; + if ((@from > 0) && (@to > 0)) { + my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to); + if (!@diffs) { + $canclone = 1; + } + } + } + return $canclone; +} + # ------------------------------------------------------- Course Group routines sub get_coursegroups { @@ -9436,9 +9521,9 @@ sub modify_access_controls { my $tries = 0; my $gotlock = &newput('file_permissions',$lockhash,$domain,$user); - while (($gotlock ne 'ok') && $tries <3) { + while (($gotlock ne 'ok') && $tries < 10) { $tries ++; - sleep 1; + sleep(0.1); $gotlock = &newput('file_permissions',$lockhash,$domain,$user); } if ($gotlock eq 'ok') { @@ -12726,10 +12811,11 @@ BEGIN { my $item = $token->[1]; my $name = $token->[2]{'name'}; my $value = $token->[2]{'value'}; - if ($item ne '' && $name ne '' && $value ne '') { + my $valuematch = $token->[2]{'valuematch'}; + if ($item ne '' && $name ne '' && ($value ne '' || $valuematch ne '')) { my $release = $parser->get_text(); $release =~ s/(^\s*|\s*$ )//gx; - $needsrelease{$item.':'.$name.':'.$value} = $release; + $needsrelease{$item.':'.$name.':'.$value.':'.$valuematch} = $release; } } } @@ -13052,13 +13138,29 @@ escaped strings of the action recorded i =item * -allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions +allowed($priv,$uri,$symb,$role,$clientip,$noblockcheck) : check for a user privilege; +returns codes for allowed actions. + +The first argument is required, all others are optional. + +$priv is the privilege being checked. +$uri contains additional information about what is being checked for access (e.g., +URL, course ID etc.). +$symb is the unique resource instance identifier in a course; if needed, +but not provided, it will be retrieved via a call to &symbread(). +$role is the role for which a priv is being checked (only used if priv is evb). +$clientip is the user's IP address (only used when checking for access to portfolio +files). +$noblockcheck, if true, skips calls to &has_comm_blocking() for the bre priv. This +prevents recursive calls to &allowed. + F: full access U,I,K: authentication modes (cxx only) '': forbidden 1: user needs to choose course 2: browse allowed A: passphrase authentication needed + B: access temporarily blocked because of a blocking event in a course. =item *