--- loncom/lonnet/perl/lonnet.pm 2016/08/05 15:14:19 1.1172.2.71 +++ loncom/lonnet/perl/lonnet.pm 2014/01/05 11:43:58 1.1249 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1172.2.71 2016/08/05 15:14:19 raeburn Exp $ +# $Id: lonnet.pm,v 1.1249 2014/01/05 11:43:58 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -75,6 +75,9 @@ use LWP::UserAgent(); use HTTP::Date; use Image::Magick; + +use Encode; + use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease %managerstab); @@ -109,6 +112,7 @@ require Exporter; our @ISA = qw (Exporter); our @EXPORT = qw(%env); + # ------------------------------------ Logging (parameters, docs, slots, roles) { my $logid; @@ -123,19 +127,19 @@ our @EXPORT = qw(%env); $logid ++; my $now = time(); my $id=$now.'00000'.$$.'00000'.$logid; - my $logentry = { - $id => { - 'exe_uname' => $env{'user.name'}, - 'exe_udom' => $env{'user.domain'}, - 'exe_time' => $now, - 'exe_ip' => $ENV{'REMOTE_ADDR'}, - 'delflag' => $delflag, - 'logentry' => $storehash, - 'uname' => $uname, - 'udom' => $udom, - } + my $logentry = { + $id => { + 'exe_uname' => $env{'user.name'}, + 'exe_udom' => $env{'user.domain'}, + 'exe_time' => $now, + 'exe_ip' => $ENV{'REMOTE_ADDR'}, + 'delflag' => $delflag, + 'logentry' => $storehash, + 'uname' => $uname, + 'udom' => $udom, + } }; - return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum); + return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum); } } @@ -356,7 +360,8 @@ sub remote_devalidate_cache { my $items; return unless (ref($cachekeys) eq 'ARRAY'); my $cachestr = join('&',@{$cachekeys}); - return &reply('devalidatecache:'.&escape($cachestr),$lonhost); + my $response = &reply('devalidatecache:'.&escape($cachestr),$lonhost); + return $response; } # -------------------------------------------------- Non-critical communication @@ -671,7 +676,7 @@ sub appenv { if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) { $refused = 1; if (ref($roles) eq 'ARRAY') { - my ($type,$role) = ($key =~ m{^user\.(role|priv)\.(.+?)\./}); + my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./); if (grep(/^\Q$role\E$/,@{$roles})) { $refused = 0; } @@ -844,8 +849,10 @@ sub spareserver { if (ref($spareshash) eq 'HASH') { if (ref($spareshash->{'primary'}) eq 'ARRAY') { foreach my $try_server (@{ $spareshash->{'primary'} }) { - next unless (&spare_can_host($udom,$uint_dom,$remotesessions, - $try_server)); + if ($uint_dom) { + next unless (&spare_can_host($udom,$uint_dom,$remotesessions, + $try_server)); + } ($spare_server, $lowest_load) = &compare_server_load($try_server, $spare_server, $lowest_load); } @@ -856,8 +863,10 @@ sub spareserver { if (!$found_server) { if (ref($spareshash->{'default'}) eq 'ARRAY') { foreach my $try_server (@{ $spareshash->{'default'} }) { - next unless (&spare_can_host($udom,$uint_dom, - $remotesessions,$try_server)); + if ($uint_dom) { + next unless (&spare_can_host($udom,$uint_dom, + $remotesessions,$try_server)); + } ($spare_server, $lowest_load) = &compare_server_load($try_server, $spare_server, $lowest_load); } @@ -881,17 +890,7 @@ sub spareserver { } sub compare_server_load { - my ($try_server, $spare_server, $lowest_load, $required) = @_; - - if ($required) { - my ($reqdmajor,$reqdminor) = ($required =~ /^(\d+)\.(\d+)$/); - my $remoterev = &get_server_loncaparev(undef,$try_server); - my ($major,$minor) = ($remoterev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); - if (($major eq '' && $minor eq '') || - (($reqdmajor > $major) || (($reqdmajor == $major) && ($reqdminor > $minor)))) { - return ($spare_server,$lowest_load); - } - } + my ($try_server, $spare_server, $lowest_load) = @_; my $loadans = &reply('load', $try_server); my $userloadans = &reply('userload',$try_server); @@ -952,43 +951,26 @@ sub has_user_session { # --------- determine least loaded server in a user's domain which allows login sub choose_server { - my ($udom,$checkloginvia,$required,$skiploadbal) = @_; + my ($udom,$checkloginvia) = @_; my %domconfhash = &Apache::loncommon::get_domainconf($udom); my %servers = &get_servers($udom); my $lowest_load = 30000; - my ($login_host,$hostname,$portal_path,$isredirect,$balancers); - if ($skiploadbal) { - ($balancers,my $cached)=&is_cached_new('loadbalancing',$udom); - unless (defined($cached)) { - my $cachetime = 60*60*24; - my %domconfig = - &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom); - if (ref($domconfig{'loadbalancing'}) eq 'HASH') { - $balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'}, - $cachetime); - } - } - } + my ($login_host,$hostname,$portal_path,$isredirect); foreach my $lonhost (keys(%servers)) { my $loginvia; - if ($skiploadbal) { - if (ref($balancers) eq 'HASH') { - next if (exists($balancers->{$lonhost})); - } - } if ($checkloginvia) { $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost}; if ($loginvia) { my ($server,$path) = split(/:/,$loginvia); ($login_host, $lowest_load) = - &compare_server_load($server, $login_host, $lowest_load, $required); + &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, $required); + &compare_server_load($lonhost, $login_host, $lowest_load); if ($login_host eq $lonhost) { $portal_path = ''; $isredirect = ''; @@ -996,7 +978,7 @@ sub choose_server { } } else { ($login_host, $lowest_load) = - &compare_server_load($lonhost, $login_host, $lowest_load, $required); + &compare_server_load($lonhost, $login_host, $lowest_load); } } if ($login_host ne '') { @@ -1169,27 +1151,19 @@ sub can_host_session { sub spare_can_host { my ($udom,$uint_dom,$remotesessions,$try_server)=@_; my $canhost=1; - my $try_server_hostname = &hostname($try_server); - my $serverhomeID = &get_server_homeID($try_server_hostname); - my $serverhomedom = &host_domain($serverhomeID); - my %defdomdefaults = &get_domain_defaults($serverhomedom); - if (ref($defdomdefaults{'offloadnow'}) eq 'HASH') { - if ($defdomdefaults{'offloadnow'}{$try_server}) { - $canhost = 0; - } - } - if (($canhost) && ($uint_dom)) { - my @intdoms; - my $internet_names = &get_internet_names($try_server); - if (ref($internet_names) eq 'ARRAY') { - @intdoms = @{$internet_names}; - } - unless (grep(/^\Q$uint_dom\E$/,@intdoms)) { - my $remoterev = &get_server_loncaparev(undef,$try_server); - $canhost = &can_host_session($udom,$try_server,$remoterev, - $remotesessions, - $defdomdefaults{'hostedsessions'}); - } + my @intdoms; + my $internet_names = &Apache::lonnet::get_internet_names($try_server); + if (ref($internet_names) eq 'ARRAY') { + @intdoms = @{$internet_names}; + } + unless (grep(/^\Q$uint_dom\E$/,@intdoms)) { + my $serverhomeID = &Apache::lonnet::get_server_homeID($try_server); + my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID); + my %defdomdefaults = &Apache::lonnet::get_domain_defaults($serverhomedom); + my $remoterev = &Apache::lonnet::get_server_loncaparev(undef,$try_server); + $canhost = &can_host_session($udom,$try_server,$remoterev, + $remotesessions, + $defdomdefaults{'hostedsessions'}); } return $canhost; } @@ -1301,7 +1275,7 @@ sub check_loadbalancing { } } if (ref($result) eq 'HASH') { - ($is_balancer,$currtargets,$currrules) = + ($is_balancer,$currtargets,$currrules) = &check_balancer_result($result,@hosts); if ($is_balancer) { if (ref($currrules) eq 'HASH') { @@ -1360,7 +1334,7 @@ sub check_loadbalancing { } } if (ref($result) eq 'HASH') { - ($is_balancer,$currtargets,$currrules) = + ($is_balancer,$currtargets,$currrules) = &check_balancer_result($result,@hosts); if ($is_balancer) { if (ref($currrules) eq 'HASH') { @@ -1416,8 +1390,8 @@ sub check_loadbalancing { $is_balancer = 0; if ($uname ne '' && $udom ne '') { if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { - - &appenv({'user.loadbalexempt' => $lonhost, + + &appenv({'user.loadbalexempt' => $lonhost, 'user.loadbalcheck.time' => time}); } } @@ -1606,7 +1580,7 @@ sub idput { } } -# ---------------------------------------- Delete unwanted IDs from ids.db file +# ---------------------------------------- Delete unwanted IDs from ids.db file sub iddel { my ($udom,$idshashref,$uhome)=@_; @@ -1651,7 +1625,6 @@ sub dump_dom { sub get_dom { my ($namespace,$storearr,$udom,$uhome)=@_; - return if ($udom eq 'public'); my $items=''; foreach my $item (@$storearr) { $items.=&escape($item).'&'; @@ -1659,7 +1632,6 @@ sub get_dom { $items=~s/\&$//; if (!$udom) { $udom=$env{'user.domain'}; - return if ($udom eq 'public'); if (defined(&domain($udom,'primary'))) { $uhome=&domain($udom,'primary'); } else { @@ -1763,13 +1735,14 @@ sub retrieve_inst_usertypes { my %domdefs = &Apache::lonnet::get_domain_defaults($udom); if ((ref($domdefs{'inststatustypes'}) eq 'HASH') && (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) { - return ($domdefs{'inststatustypes'},$domdefs{'inststatusorder'}); + %returnhash = %{$domdefs{'inststatustypes'}}; + @order = @{$domdefs{'inststatusorder'}}; } else { if (defined(&domain($udom,'primary'))) { my $uhome=&domain($udom,'primary'); my $rep=&reply("inst_usertypes:$udom",$uhome); if ($rep =~ /^(con_lost|error|no_such_host|refused)/) { - &logthis("retrieve_inst_usertypes failed - $rep returned from $uhome in domain: $udom"); + &logthis("get_dom failed - $rep returned from $uhome in domain: $udom"); return (\%returnhash,\@order); } my ($hashitems,$orderitems) = split(/:/,$rep); @@ -1785,10 +1758,10 @@ sub retrieve_inst_usertypes { push(@order,&unescape($item)); } } else { - &logthis("retrieve_inst_usertypes failed - no primary domain server for $udom"); + &logthis("get_dom failed - no primary domain server for $udom"); } - return (\%returnhash,\@order); } + return (\%returnhash,\@order); } sub is_domainimage { @@ -1934,63 +1907,6 @@ sub get_instuser { return ($outcome,%userinfo); } -sub get_multiple_instusers { - my ($udom,$users,$caller) = @_; - my ($outcome,$results); - if (ref($users) eq 'HASH') { - my $count = keys(%{$users}); - my $requested = &freeze_escape($users); - my $homeserver = &domain($udom,'primary'); - if ($homeserver ne '') { - my $queryid=&reply('querysend:getmultinstusers:::'.$caller.'='.$requested,$homeserver); - my $host=&hostname($homeserver); - if ($queryid !~/^\Q$host\E\_/) { - &logthis('get_multiple_instusers invalid queryid: '.$queryid. - ' for host: '.$homeserver.'in domain '.$udom); - return ($outcome,$results); - } - my $response = &get_query_reply($queryid); - my $maxtries = 5; - if ($count > 100) { - $maxtries = 1+int($count/20); - } - my $tries = 1; - while (($response=~/^timeout/) && ($tries <= $maxtries)) { - $response = &get_query_reply($queryid); - $tries ++; - } - if ($response eq '') { - $results = {}; - foreach my $key (keys(%{$users})) { - my ($uname,$id); - if ($caller eq 'id') { - $id = $key; - } else { - $uname = $key; - } - my ($resp,%info) = &get_instuser($udom,$uname,$id); - $outcome = $resp; - if ($resp eq 'ok') { - %{$results} = (%{$results}, %info); - } else { - last; - } - } - } elsif(!&error($response) && ($response ne 'refused')) { - if (($response eq 'unavailable') || ($response eq 'invalid') || ($response eq 'timeout')) { - $outcome = $response; - } else { - ($outcome,my $userdata) = split(/=/,$response,2); - if ($outcome eq 'ok') { - $results = &thaw_unescape($userdata); - } - } - } - } - } - return ($outcome,$results); -} - sub inst_rulecheck { my ($udom,$uname,$id,$item,$rules) = @_; my %returnhash; @@ -2086,9 +2002,7 @@ sub get_domain_defaults { &Apache::lonnet::get_dom('configuration',['defaults','quotas', 'requestcourses','inststatus', 'coursedefaults','usersessions', - 'requestauthor','selfenrollment', - 'coursecategories'],$domain); - my @coursetypes = ('official','unofficial','community','textbook'); + 'requestauthor'],$domain); if (ref($domconfig{'defaults'}) eq 'HASH') { $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; @@ -2126,41 +2040,22 @@ sub get_domain_defaults { $domdefaults{'requestauthor'} = $domconfig{'requestauthor'}; } if (ref($domconfig{'inststatus'}) eq 'HASH') { - foreach my $item ('inststatustypes','inststatusorder','inststatusguest') { + foreach my $item ('inststatustypes','inststatusorder') { $domdefaults{$item} = $domconfig{'inststatus'}{$item}; } } if (ref($domconfig{'coursedefaults'}) eq 'HASH') { - $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'}; - $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'}; - if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') { - $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'}; - } - foreach my $type (@coursetypes) { - if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') { - unless ($type eq 'community') { - $domdefaults{$type.'credits'} = $domconfig{'coursedefaults'}{'coursecredits'}{$type}; - } - } - if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') { - $domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type}; - } - if ($domdefaults{'postsubmit'} eq 'on') { - if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') { - $domdefaults{$type.'postsubtimeout'} = - $domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type}; - } - } - } - 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'}; + $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'}; + if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') { + $domdefaults{'officialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'official'}; + $domdefaults{'unofficialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'unofficial'}; + $domdefaults{'textbookcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'textbook'}; + } + if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') { + $domdefaults{'officialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'official'}; + $domdefaults{'unofficialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'unofficial'}; + $domdefaults{'communityquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'community'}; + $domdefaults{'textbookquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'textbook'}; } } if (ref($domconfig{'usersessions'}) eq 'HASH') { @@ -2170,47 +2065,6 @@ sub get_domain_defaults { if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') { $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'}; } - if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') { - $domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'}; - } - } - if (ref($domconfig{'selfenrollment'}) eq 'HASH') { - if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') { - my @settings = ('types','registered','enroll_dates','access_dates','section', - 'approval','limit'); - foreach my $type (@coursetypes) { - if (ref($domconfig{'selfenrollment'}{'admin'}{$type}) eq 'HASH') { - my @mgrdc = (); - foreach my $item (@settings) { - if ($domconfig{'selfenrollment'}{'admin'}{$type}{$item} eq '0') { - push(@mgrdc,$item); - } - } - if (@mgrdc) { - $domdefaults{$type.'selfenrolladmdc'} = join(',',@mgrdc); - } - } - } - } - if (ref($domconfig{'selfenrollment'}{'default'}) eq 'HASH') { - foreach my $type (@coursetypes) { - if (ref($domconfig{'selfenrollment'}{'default'}{$type}) eq 'HASH') { - foreach my $item (keys(%{$domconfig{'selfenrollment'}{'default'}{$type}})) { - $domdefaults{$type.'selfenroll'.$item} = $domconfig{'selfenrollment'}{'default'}{$type}{$item}; - } - } - } - } - } - if (ref($domconfig{'coursecategories'}) eq 'HASH') { - $domdefaults{'catauth'} = 'std'; - $domdefaults{'catunauth'} = 'std'; - if ($domconfig{'coursecategories'}{'auth'}) { - $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'}; - } - if ($domconfig{'coursecategories'}{'unauth'}) { - $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'}; - } } &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime); return %domdefaults; @@ -2802,22 +2656,20 @@ sub ssi { &Apache::lonenc::check_encrypt(\$fn); if (%form) { $request=new HTTP::Request('POST',&absolute_url().$fn); - $request->content(join('&',map { - my $name = escape($_); - "$name=" . ( ref($form{$_}) eq 'ARRAY' - ? join("&$name=", map {escape($_) } @{$form{$_}}) - : &escape($form{$_}) ); - } keys(%form))); + $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form))); } else { $request=new HTTP::Request('GET',&absolute_url().$fn); } $request->header(Cookie => $ENV{'HTTP_COOKIE'}); my $response= $ua->request($request); + my $content = $response->content; + + if (wantarray) { - return ($response->content, $response); + return ($content, $response); } else { - return $response->content; + return $content; } } @@ -2849,7 +2701,7 @@ sub allowuploaded { # # Determine if the current user should be able to edit a particular resource, # when viewing in course context. -# (a) When viewing resource used to determine if "Edit" item is included in +# (a) When viewing resource used to determine if "Edit" item is included in # Functions. # (b) When displaying folder contents in course editor, used to determine if # "Edit" link will be displayed alongside resource. @@ -2857,12 +2709,12 @@ sub allowuploaded { # input: six args -- filename (decluttered), course number, course domain, # url, symb (if registered) and group (if this is a group # item -- e.g., bulletin board, group page etc.). -# output: array of five scalars -- +# output: array of five scalars -- # $cfile -- url for file editing if editable on current server # $home -- homeserver of resource (i.e., for author if published, # or course if uploaded.). # $switchserver -- 1 if server switch will be needed. -# $forceedit -- 1 if icon/link should be to go to edit mode +# $forceedit -- 1 if icon/link should be to go to edit mode # $forceview -- 1 if icon/link should be to go to view mode # @@ -2951,7 +2803,7 @@ sub can_edit_resource { $forceedit = 1; } $cfile = $resurl; - } elsif (($resurl ne '') && (&is_on_map($resurl))) { + } elsif (($resurl ne '') && (&is_on_map($resurl))) { if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) { $incourse = 1; if ($env{'form.forceedit'}) { @@ -2982,7 +2834,7 @@ sub can_edit_resource { } } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') { my $template = '/res/lib/templates/simpleproblem.problem'; - if (&is_on_map($template)) { + if (&is_on_map($template)) { $incourse = 1; $forceview = 1; $cfile = $template; @@ -3029,7 +2881,7 @@ sub can_edit_resource { $cfile=$file; } } - if (($cfile ne '') && (!$incourse || $uploaded) && + if (($cfile ne '') && (!$incourse || $uploaded) && (($home ne '') && ($home ne 'no_host'))) { my @ids=¤t_machine_ids(); unless (grep(/^\Q$home\E$/,@ids)) { @@ -3056,9 +2908,9 @@ sub in_course { if ($hideprivileged) { my $skipuser; my %coursehash = &coursedescription($cdom.'_'.$cnum); - my @possdoms = ($cdom); - if ($coursehash{'checkforpriv'}) { - push(@possdoms,split(/,/,$coursehash{'checkforpriv'})); + my @possdoms = ($cdom); + if ($coursehash{'checkforpriv'}) { + push(@possdoms,split(/,/,$coursehash{'checkforpriv'})); } if (&privileged($uname,$udom,\@possdoms)) { $skipuser = 1; @@ -3562,7 +3414,7 @@ sub extract_embedded_items { } if (lc($tagname) eq 'a') { unless (($attr->{'href'} =~ /^#/) || ($attr->{'href'} eq '')) { - &add_filetype($allfiles,$attr->{'href'},'href'); + &add_filetype($allfiles,$attr->{'href'},'href'); } } if (lc($tagname) eq 'script') { @@ -4233,7 +4085,7 @@ sub get_my_roles { } else { my $possdoms = [$domain]; if (ref($roledoms) eq 'ARRAY') { - push(@{$possdoms},@{$roledoms}); + push(@{$possdoms},@{$roledoms}); } if (&privileged($username,$domain,$possdoms,\@privroles)) { if (!$nothide{$username.':'.$domain}) { @@ -4328,7 +4180,7 @@ sub courseiddump { $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone, $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner, - $hasuniquecode,$reqcrsdom,$reqinstcode)=@_; + $hasuniquecode)=@_; my $as_hash = 1; my %returnhash; if (!$domfilter) { $domfilter=''; } @@ -4341,18 +4193,17 @@ sub courseiddump { if (($domfilter eq '') || (&host_domain($tryserver) eq $domfilter)) { my $rep; - if (grep { $_ eq $tryserver } ¤t_machine_ids()) { - $rep = &LONCAPA::Lond::dump_course_id_handler( - join(":", (&host_domain($tryserver), $sincefilter, - &escape($descfilter), &escape($instcodefilter), + if (grep { $_ eq $tryserver } current_machine_ids()) { + $rep = LONCAPA::Lond::dump_course_id_handler( + join(":", (&host_domain($tryserver), $sincefilter, + &escape($descfilter), &escape($instcodefilter), &escape($ownerfilter), &escape($coursefilter), - &escape($typefilter), &escape($regexp_ok), - $as_hash, &escape($selfenrollonly), - &escape($catfilter), $showhidden, $caller, - &escape($cloner), &escape($cc_clone), $cloneonly, - &escape($createdbefore), &escape($createdafter), - &escape($creationcontext),$domcloner,$hasuniquecode, - $reqcrsdom,&escape($reqinstcode)))); + &escape($typefilter), &escape($regexp_ok), + $as_hash, &escape($selfenrollonly), + &escape($catfilter), $showhidden, $caller, + &escape($cloner), &escape($cc_clone), $cloneonly, + &escape($createdbefore), &escape($createdafter), + &escape($creationcontext), $domcloner, $hasuniquecode))); } else { $rep = &reply('courseiddump:'.&host_domain($tryserver).':'. $sincefilter.':'.&escape($descfilter).':'. @@ -4363,10 +4214,10 @@ sub courseiddump { $showhidden.':'.$caller.':'.&escape($cloner).':'. &escape($cc_clone).':'.$cloneonly.':'. &escape($createdbefore).':'.&escape($createdafter).':'. - &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode. - ':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver); + &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode, + $tryserver); } - + my @pairs=split(/\&/,$rep); foreach my $item (@pairs) { my ($key,$value)=split(/\=/,$item,2); @@ -4503,7 +4354,7 @@ my $cachedkey=''; # The cached times for this user my %cachedtimes=(); # When this was last done -my $cachedtime=''; +my $cachedtime=(); sub load_all_first_access { my ($uname,$udom)=@_; @@ -4565,92 +4416,6 @@ sub set_first_access { return 'already_set'; } } - -sub checkout { - my ($symb,$tuname,$tudom,$tcrsid)=@_; - my $now=time; - my $lonhost=$perlvar{'lonHostID'}; - my $infostr=&escape( - 'CHECKOUTTOKEN&'. - $tuname.'&'. - $tudom.'&'. - $tcrsid.'&'. - $symb.'&'. - $now.'&'.$ENV{'REMOTE_ADDR'}); - my $token=&reply('tmpput:'.$infostr,$lonhost); - if ($token=~/^error\:/) { - &logthis("WARNING: ". - "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb. - ""); - return ''; - } - - $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/; - $token=~tr/a-z/A-Z/; - - my %infohash=('resource.0.outtoken' => $token, - 'resource.0.checkouttime' => $now, - 'resource.0.outremote' => $ENV{'REMOTE_ADDR'}); - - unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { - return ''; - } else { - &logthis("WARNING: ". - "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb. - ""); - } - - if (&log($tudom,$tuname,&homeserver($tuname,$tudom), - &escape('Checkout '.$infostr.' - '. - $token)) ne 'ok') { - return ''; - } else { - &logthis("WARNING: ". - "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb. - ""); - } - return $token; -} - -# ------------------------------------------------------------ Check in an item - -sub checkin { - my $token=shift; - my $now=time; - my ($ta,$tb,$lonhost)=split(/\*/,$token); - $lonhost=~tr/A-Z/a-z/; - my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb; - $dtoken=~s/\W/\_/g; - my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= - split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); - - unless (($tuname) && ($tudom)) { - &logthis('Check in '.$token.' ('.$dtoken.') failed'); - return ''; - } - - unless (&allowed('mgr',$tcrsid)) { - &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '. - $env{'user.name'}.' - '.$env{'user.domain'}); - return ''; - } - - my %infohash=('resource.0.intoken' => $token, - 'resource.0.checkintime' => $now, - 'resource.0.inremote' => $ENV{'REMOTE_ADDR'}); - - unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { - return ''; - } - - if (&log($tudom,$tuname,&homeserver($tuname,$tudom), - &escape('Checkin - '.$token)) ne 'ok') { - return ''; - } - - return ($symb,$tuname,$tudom,$tcrsid); -} - # --------------------------------------------- Set Expire Date for Spreadsheet sub expirespread { @@ -5021,7 +4786,7 @@ sub tmprestore { # ----------------------------------------------------------------------- Store sub store { - my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_; + my ($storehash,$symb,$namespace,$domain,$stuname) = @_; my $home=''; if ($stuname) { $home=&homeserver($stuname,$domain); } @@ -5051,13 +4816,13 @@ sub store { } $namevalue=~s/\&$//; &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); - return reply("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home"); + return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); } # -------------------------------------------------------------- Critical Store sub cstore { - my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_; + my ($storehash,$symb,$namespace,$domain,$stuname) = @_; my $home=''; if ($stuname) { $home=&homeserver($stuname,$domain); } @@ -5088,7 +4853,7 @@ sub cstore { $namevalue=~s/\&$//; &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); return critical - ("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home"); + ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); } # --------------------------------------------------------------------- Restore @@ -5244,7 +5009,7 @@ sub privileged { my $now = time; my $roles; if (ref($possroles) eq 'ARRAY') { - $roles = $possroles; + $roles = $possroles; } else { $roles = ['dc','su']; } @@ -5268,10 +5033,10 @@ sub privileged { my %rolesdump = &dump("roles", $domain, $username) or return 0; my $now = time; - for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys(%rolesdump)}) { + for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) { my ($trole, $tend, $tstart) = split(/_/, $role); if (grep(/^\Q$trole\E$/,@{$roles})) { - return 1 unless ($tend && $tend < $now) + return 1 unless ($tend && $tend < $now) or ($tstart && $tstart > $now); } } @@ -5309,7 +5074,7 @@ sub privileged_by_domain { my ($trole,$uname,$udom,$rest) = split(/:/,$item,4); my ($end,$start) = split(/:/,$dompersonnel{$server}{$item}); next if ($end && $end < $now); - $privileged{$dom}{$trole}{$uname.':'.$udom} = + $privileged{$dom}{$trole}{$uname.':'.$udom} = $dompersonnel{$server}{$item}; } } @@ -5357,7 +5122,7 @@ sub rolesinit { my %allroles=(); my %allgroups=(); - for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) { + for my $area (grep { ! /^rolesdef_/ } keys %rolesdump) { my $role = $rolesdump{$area}; $area =~ s/\_\w\w$//; @@ -5449,7 +5214,7 @@ sub set_arearole { sub custom_roleprivs { my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_; my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); - my $homsvr = &homeserver($rauthor,$rdomain); + my $homsvr=homeserver($rauthor,$rdomain); if (&hostname($homsvr) ne '') { my ($rdummy,$roledef)= &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); @@ -5570,11 +5335,11 @@ sub set_userprivs { sub role_status { my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_; + my @pwhere = (); if (exists($env{$rolekey}) && $env{$rolekey} ne '') { - my ($one,$two) = split(m{\./},$rolekey,2); - (undef,undef,$$role) = split(/\./,$one,3); + (undef,undef,$$role,@pwhere)=split(/\./,$rolekey); unless (!defined($$role) || $$role eq '') { - $$where = '/'.$two; + $$where=join('.',@pwhere); $$trolecode=$$role.'.'.$$where; ($$tstart,$$tend)=split(/\./,$env{$rolekey}); $$tstatus='is'; @@ -5780,14 +5545,15 @@ sub unserialize { return {} if $rep =~ /^error/; my %returnhash=(); - foreach my $item (split(/\&/,$rep)) { - my ($key, $value) = split(/=/, $item, 2); - $key = unescape($key) unless $escapedkeys; - next if $key =~ /^error: 2 /; - $returnhash{$key} = &thaw_unescape($value); - } + foreach my $item (split /\&/, $rep) { + my ($key, $value) = split(/=/, $item, 2); + $key = unescape($key) unless $escapedkeys; + next if $key =~ /^error: 2 /; + $returnhash{$key} = Apache::lonnet::thaw_unescape($value); + } + #return %returnhash; return \%returnhash; -} +} # see Lond::dump_with_regexp # if $escapedkeys hash keys won't get unescaped. @@ -5797,16 +5563,17 @@ sub dump { if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); - if ($regexp) { - $regexp=&escape($regexp); - } else { - $regexp='.'; - } - if (grep { $_ eq $uhome } ¤t_machine_ids()) { + my $reply; + if (grep { $_ eq $uhome } current_machine_ids()) { # user is hosted on this machine - my $reply = LONCAPA::Lond::dump_with_regexp(join(':', ($udomain, + $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain, $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'}); - return %{&unserialize($reply, $escapedkeys)}; + return %{unserialize($reply, $escapedkeys)}; + } + if ($regexp) { + $regexp=&escape($regexp); + } else { + $regexp='.'; } my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); my @pairs=split(/\&/,$rep); @@ -5814,7 +5581,8 @@ sub dump { if (!($rep =~ /^error/ )) { foreach my $item (@pairs) { my ($key,$value)=split(/=/,$item,2); - $key = &unescape($key) unless ($escapedkeys); + $key = unescape($key) unless $escapedkeys; + #$key = &unescape($key); next if ($key =~ /^error: 2 /); $returnhash{$key}=&thaw_unescape($value); } @@ -5858,7 +5626,7 @@ sub currentdump { my $rep; if (grep { $_ eq $uhome } current_machine_ids()) { - $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname, + $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname, $courseid))); } else { $rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); @@ -5984,7 +5752,7 @@ sub newput { # --------------------------------------------------------- putstore interface sub putstore { - my ($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog)=@_; + my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_; if (!$udomain) { $udomain=$env{'user.domain'}; } if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); @@ -5998,17 +5766,6 @@ sub putstore { my $reply = &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items", $uhome); - if (($tolog) && ($reply eq 'ok')) { - my $namevalue=''; - foreach my $key (keys(%{$storehash})) { - $namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&'; - } - $namevalue .= 'ip='.&escape($ENV{'REMOTE_ADDR'}). - '&host='.&escape($perlvar{'lonHostID'}). - '&version='.$esc_v. - '&by='.&escape($env{'user.name'}.':'.$env{'user.domain'}); - &Apache::lonnet::courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue); - } if ($reply eq 'unknown_cmd') { # gfall back to way things use to be done return &old_putstore($namespace,$symb,$version,$storehash,$udomain, @@ -6117,13 +5874,13 @@ sub tmpdel { return &reply("tmpdel:$token",$server); } -# ------------------------------------------------------------ get_timebased_id +# ------------------------------------------------------------ get_timebased_id sub get_timebased_id { my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries, $maxtries) = @_; my ($newid,$error,$dellock); - unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) { + unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) { return ('','ok','invalid call to get suffix'); } @@ -6137,7 +5894,7 @@ sub get_timebased_id { if (!$maxtries) { $maxtries = 10; } - + if (($cdom eq '') || ($cnum eq '')) { if ($env{'request.course.id'}) { $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; @@ -6167,15 +5924,10 @@ sub get_timebased_id { my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix); my $id = time; $newid = $id; - if ($idtype eq 'addcode') { - $newid .= &sixnum_code(); - } my $idtries = 0; while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) { if ($idtype eq 'concat') { $newid = $id.$idtries; - } elsif ($idtype eq 'addcode') { - $newid = $newid.&sixnum_code(); } else { $newid ++; } @@ -6192,7 +5944,6 @@ sub get_timebased_id { $error = 'error saving new item: '.$putresult; } } else { - undef($newid); $error = ('error: no unique suffix available for the new item '); } # remove lock @@ -6201,21 +5952,10 @@ sub get_timebased_id { } else { $error = "error: could not obtain lockfile\n"; $dellock = 'ok'; - if (($prefix eq 'paste') && ($namespace eq 'courseeditor') && ($keyid eq 'num')) { - $dellock = 'nolock'; - } } return ($newid,$dellock,$error); } -sub sixnum_code { - my $code; - for (0..6) { - $code .= int( rand(9) ); - } - return $code; -} - # -------------------------------------------------- portfolio access checking sub portfolio_access { @@ -6505,7 +6245,7 @@ sub usertools_access { my ($toolstatus,$inststatus,$envkey); if ($context eq 'requestauthor') { - $envkey = $context; + $envkey = $context; } else { $envkey = $context.'.'.$tool; } @@ -6767,7 +6507,7 @@ sub customaccess { # ------------------------------------------------- Check for a user privilege sub allowed { - my ($priv,$uri,$symb,$role,$clientip,$noblockcheck)=@_; + my ($priv,$uri,$symb,$role)=@_; my $ver_orguri=$uri; $uri=&deversion($uri); my $orguri=$uri; @@ -6962,16 +6702,11 @@ sub allowed { if ($match) { if ($env{'user.priv.'.$env{'request.role'}.'./'} =~/\Q$priv\E\&([^\:]*)/) { - my $value = $1; - if ($noblockcheck) { - $thisallowed.=$value; + my @blockers = &has_comm_blocking($priv,$symb,$uri); + if (@blockers > 0) { + $thisallowed = 'B'; } else { - my @blockers = &has_comm_blocking($priv,$symb,$uri); - if (@blockers > 0) { - $thisallowed = 'B'; - } else { - $thisallowed.=$value; - } + $thisallowed.=$1; } } } else { @@ -6983,15 +6718,11 @@ sub allowed { $refuri=&declutter($refuri); my ($match) = &is_on_map($refuri); if ($match) { - if ($noblockcheck) { - $thisallowed='F'; + my @blockers = &has_comm_blocking($priv,$symb,$refuri); + if (@blockers > 0) { + $thisallowed = 'B'; } else { - my @blockers = &has_comm_blocking($priv,$symb,$refuri); - if (@blockers > 0) { - $thisallowed = 'B'; - } else { - $thisallowed='F'; - } + $thisallowed='F'; } } } @@ -7046,15 +6777,11 @@ sub allowed { =~/\Q$priv\E\&([^\:]*)/) { my $value = $1; if ($priv eq 'bre') { - if ($noblockcheck) { - $thisallowed.=$value; + my @blockers = &has_comm_blocking($priv,$symb,$uri); + if (@blockers > 0) { + $thisallowed = 'B'; } else { - my @blockers = &has_comm_blocking($priv,$symb,$uri); - if (@blockers > 0) { - $thisallowed = 'B'; - } else { - $thisallowed.=$value; - } + $thisallowed.=$value; } } else { $thisallowed.=$value; @@ -7088,15 +6815,11 @@ sub allowed { =~/\Q$priv\E\&([^\:]*)/) { my $value = $1; if ($priv eq 'bre') { - if ($noblockcheck) { - $thisallowed.=$value; + my @blockers = &has_comm_blocking($priv,$symb,$refuri); + if (@blockers > 0) { + $thisallowed = 'B'; } else { - my @blockers = &has_comm_blocking($priv,$symb,$refuri); - if (@blockers > 0) { - $thisallowed = 'B'; - } else { - $thisallowed.=$value; - } + $thisallowed.=$value; } } else { $thisallowed.=$value; @@ -7327,32 +7050,6 @@ sub constructaccess { return ''; } -# ----------------------------------------------------------- Content Blocking - -{ -# Caches for faster Course Contents display where content blocking -# is in operation (i.e., interval param set) for timed quiz. -# -# User for whom data are being temporarily cached. -my $cacheduser=''; -# Cached blockers for this user (a hash of blocking items). -my %cachedblockers=(); -# When the data were last cached. -my $cachedlast=''; - -sub load_all_blockers { - my ($uname,$udom,$blocks)=@_; - if (($uname ne '') && ($udom ne '')) { - if (($cacheduser eq $uname.':'.$udom) && - (abs($cachedlast-time)<5)) { - return; - } - } - $cachedlast=time; - $cacheduser=$uname.':'.$udom; - %cachedblockers = &get_commblock_resources($blocks); -} - sub get_comm_blocks { my ($cdom,$cnum) = @_; if ($cdom eq '' || $cnum eq '') { @@ -7373,21 +7070,27 @@ sub get_comm_blocks { return %commblocks; } -sub get_commblock_resources { - my ($blocks) = @_; - my %blockers = (); - return %blockers unless ($env{'request.course.id'}); - return %blockers if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/); +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 %blockers unless (keys(%commblocks) > 0); - my $navmap = Apache::lonnavmaps::navmap->new(); - return %blockers unless (ref($navmap)); + 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); @@ -7395,13 +7098,17 @@ sub get_commblock_resources { 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 (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) { - $blockers{$block}{maps} = $commblocks{$block}{'blocks'}{'docs'}{'maps'}; + 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 (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) { - $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'}; + if ($commblocks{$block}{'blocks'}{'docs'}{'resources'}{$symb}) { + unless (grep(/^\Q$block\E$/,@blockers)) { + push(@blockers,$block); + } } } } @@ -7412,31 +7119,32 @@ sub get_commblock_resources { my @to_test; if (ref($commblocks{$block}{'blocks'}) eq 'HASH') { if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') { - 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); - } + 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 { - my $mapsymb = &symbread($item,1); - if ($mapsymb) { - if (ref($navmap)) { - my $mapres = $navmap->getBySymb($mapsymb); - @to_test = $mapres->retrieveResources($mapres,undef,0,0,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); - if ($interval[1] eq 'map') { + 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; } } @@ -7444,35 +7152,26 @@ sub get_commblock_resources { } } } - } - 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) { - my $activeblock; - foreach my $res (@to_test) { - if ($res->answerable()) { - $activeblock = 1; - last; - } - } - if ($activeblock) { - if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') { - if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) { - $blockers{$block}{'maps'} = $commblocks{$block}{'blocks'}{'docs'}{'maps'}; - } - } - if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') { - if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) { - $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'}; + 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; + } } } } @@ -7483,66 +7182,33 @@ sub get_commblock_resources { } } } - return %blockers; + return @blockers; } -sub has_comm_blocking { - my ($priv,$symb,$uri,$blocks) = @_; - my @blockers; - return unless ($env{'request.course.id'}); - return unless ($priv eq 'bre'); - return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/); - return if ($env{'request.state'} eq 'construct'); - &load_all_blockers($env{'user.name'},$env{'user.domain'},$blocks); - return unless (keys(%cachedblockers) > 0); - my (%possibles,@symbs); - if (!$symb) { - $symb = &symbread($uri,1,1,1,\%possibles); +sub check_docs_block { + my ($docsblock,$tocheck) =@_; + if ((ref($docsblock) ne 'HASH') || (ref($tocheck) ne 'HASH')) { + return; } - if ($symb) { - @symbs = ($symb); - } elsif (keys(%possibles)) { - @symbs = keys(%possibles); - } - my $noblock; - foreach my $symb (@symbs) { - last if ($noblock); - my ($map,$resid,$resurl)=&decode_symb($symb); - foreach my $block (keys(%cachedblockers)) { - if ($block =~ /^firstaccess____(.+)$/) { - my $item = $1; - if (($item eq $map) || ($item eq $symb)) { - $noblock = 1; - last; - } - } - if (ref($cachedblockers{$block}) eq 'HASH') { - if (ref($cachedblockers{$block}{'resources'}) eq 'HASH') { - if ($cachedblockers{$block}{'resources'}{$symb}) { - unless (grep(/^\Q$block\E$/,@blockers)) { - push(@blockers,$block); - } - } - } + if (ref($docsblock->{'maps'}) eq 'HASH') { + if ($tocheck->{'maps'}) { + if ($docsblock->{'maps'}{$tocheck->{'maps'}}) { + return 1; } - if (ref($cachedblockers{$block}{'maps'}) eq 'HASH') { - if ($cachedblockers{$block}{'maps'}{$map}) { - unless (grep(/^\Q$block\E$/,@blockers)) { - push(@blockers,$block); - } - } + } + } + if (ref($docsblock->{'resources'}) eq 'HASH') { + if ($tocheck->{'resources'}) { + if ($docsblock->{'resources'}{$tocheck->{'resources'}}) { + return 1; } } } - return if ($noblock); - return @blockers; -} + return; } -# -------------------------------- Deversion and split uri into path an filename - # -# Removes the version from a URI and +# Removes the versino from a URI and # splits it in to its filename and path to the filename. # Seems like File::Basename could have done this more clearly. # Parameters: @@ -7657,9 +7323,9 @@ sub metadata_query { my @server_list = (defined($server_array) ? @$server_array : keys(%libserv) ); for my $server (@server_list) { - my $domains = ''; + my $domains = ''; if (ref($domains_hash) eq 'HASH') { - $domains = $domains_hash->{$server}; + $domains = $domains_hash->{$server}; } unless ($custom or $customshow) { my $reply=&reply("querysend:".&escape($query).':::'.&escape($domains),$server); @@ -8156,20 +7822,17 @@ sub auto_courserequest_checks { } sub auto_courserequest_validation { - my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist,$custominfo) = @_; + my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_; my ($homeserver,$response); if ($dom =~ /^$match_domain$/) { $homeserver = &domain($dom,'primary'); } - unless ($homeserver eq 'no_host') { - my $customdata; - if (ref($custominfo) eq 'HASH') { - $customdata = &freeze_escape($custominfo); - } + unless ($homeserver eq 'no_host') { + $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner). ':'.&escape($crstype).':'.&escape($inststatuslist). - ':'.&escape($instcode).':'.&escape($instseclist).':'. - $customdata,$homeserver)); + ':'.&escape($instcode).':'.&escape($instseclist), + $homeserver)); } return $response; } @@ -8190,7 +7853,7 @@ sub auto_validate_class_sec { sub auto_crsreq_update { my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title, - $code,$accessstart,$accessend,$inbound) = @_; + $code,$inbound) = @_; my ($homeserver,%crsreqresponse); if ($cdom =~ /^$match_domain$/) { $homeserver = &domain($cdom,'primary'); @@ -8203,8 +7866,7 @@ sub auto_crsreq_update { my $response=&reply('autocrsrequpdate:'.$cdom.':'.$cnum.':'.&escape($crstype). ':'.&escape($action).':'.&escape($ownername).':'. &escape($ownerdomain).':'.&escape($fullname).':'. - &escape($title).':'.&escape($code).':'. - &escape($accessstart).':'.&escape($accessend).':'.$info,$homeserver); + &escape($title).':'.&escape($code).':'.$info,$homeserver); unless ($response =~ /(con_lost|error|no_such_host|refused)/) { my @items = split(/&/,$response); foreach my $item (@items) { @@ -8216,80 +7878,6 @@ 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 { @@ -8558,7 +8146,7 @@ sub assignrole { } } } elsif ($context eq 'requestauthor') { - if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && + if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && ($url eq '/'.$udom.'/') && ($role eq 'au')) { if ($env{'environment.requestauthor'} eq 'automatic') { $refused = ''; @@ -8566,13 +8154,13 @@ sub assignrole { my %domdefaults = &get_domain_defaults($udom); if (ref($domdefaults{'requestauthor'}) eq 'HASH') { my $checkbystatus; - if ($env{'user.adv'}) { + if ($env{'user.adv'}) { my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'}; if ($disposition eq 'automatic') { $refused = ''; } elsif ($disposition eq '') { $checkbystatus = 1; - } + } } else { $checkbystatus = 1; } @@ -8659,7 +8247,7 @@ sub assignrole { $context); } elsif (($role eq 'ca') || ($role eq 'aa')) { &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, - $context); + $context); } if ($role eq 'cc') { &autoupdate_coowners($url,$end,$start,$uname,$udom); @@ -8974,7 +8562,7 @@ sub modifystudent { # student's environment $uid = undef if (!$forceid); $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, - $gene,$usec,$end,$start,$type,$locktype, + $gene,$usec,$end,$start,$type,$locktype, $cid,$selfenroll,$context,$credits); return $reply; } @@ -10064,12 +9652,10 @@ sub get_userresdata { } #error 2 occurs when the .db doesn't exist if ($tmp!~/error: 2 /) { - if ((!defined($cached)) || ($tmp ne 'con_lost')) { - &logthis("WARNING:". - " Trying to get resource data for ". - $uname." at ".$udom.": ". - $tmp.""); - } + &logthis("WARNING:". + " Trying to get resource data for ". + $uname." at ".$udom.": ". + $tmp.""); } elsif ($tmp=~/error: 2 /) { #&EXT_cache_set($udom,$uname); &do_cache_new('userres',$hashid,undef,600); @@ -10121,7 +9707,7 @@ sub get_numsuppfiles { unless ($chome eq 'no_host') { ($suppcount,my $errors) = (0,0); my $suppmap = 'supplemental.sequence'; - ($suppcount,$errors) = + ($suppcount,$errors) = &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors); } &do_cache_new('suppcount',$hashid,$suppcount,600); @@ -10316,7 +9902,7 @@ sub EXT { $courseid = $cid; } if (($symbparm && $courseid) && - (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid))) { + (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid))) { #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; @@ -10567,7 +10153,7 @@ sub metadata { ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { return undef; } - if (($uri =~ /^priv/ || $uri=~m{^home/httpd/html/priv}) + if (($uri =~ /^priv/ || $uri=~/home\/httpd\/html\/priv/) && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) { return undef; } @@ -10828,7 +10414,7 @@ sub metadata { $metaentry{':keys'} = join(',',keys(%metathesekeys)); &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); - $metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys)); + $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); &do_cache_new('meta',$uri,\%metaentry,$cachetime); # this is the end of "was not already recently cached } @@ -11104,7 +10690,7 @@ sub symbverify { $ids=$bighash{'ids_'.&clutter($thisurl)}; } unless ($ids) { - my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl; + my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl; $ids=$bighash{$idkey}; } if ($ids) { @@ -11120,14 +10706,14 @@ sub symbverify { if (ref($encstate)) { $$encstate = $bighash{'encrypted_'.$id}; } - if (($env{'request.role.adv'}) || - ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) || + if (($env{'request.role.adv'}) || + ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) || ($thisurl eq '/adm/navmaps')) { - $okay=1; + $okay=1; last; - } - } - } + } + } + } } untie(%bighash); } @@ -11199,21 +10785,19 @@ sub deversion { # ------------------------------------------------------ Return symb list entry sub symbread { - my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles)=@_; - my $cache_str='request.symbread.cached.'.$thisfn; - if (defined($env{$cache_str})) { - if ($ignorecachednull) { - return $env{$cache_str} unless ($env{$cache_str} eq ''); - } else { + my ($thisfn,$donotrecurse)=@_; + my $cache_str; + if ($thisfn ne '') { + $cache_str='request.symbread.cached.'.$thisfn; + if ($env{$cache_str} ne '') { return $env{$cache_str}; } - } + } else { # no filename provided? try from environment - unless ($thisfn) { if ($env{'request.symb'}) { - return $env{$cache_str}=&symbclean($env{'request.symb'}); - } - $thisfn=$env{'request.filename'}; + return $env{$cache_str}=&symbclean($env{'request.symb'}); + } + $thisfn=$env{'request.filename'}; } if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } # is that filename actually a symb? Verify, clean, and return @@ -11269,46 +10853,18 @@ sub symbread { my ($mapid,$resid)=split(/\./,$ids); $syval=&encode_symb($bighash{'map_id_'.$mapid}, $resid,$thisfn); - if (ref($possibles) eq 'HASH') { - $possibles->{$syval} = 1; - } - if ($checkforblock) { - my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids}); - if (@blockers) { - $syval = ''; - return; - } - } - } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { + } elsif (!$donotrecurse) { # ------------------------------------------ There is more than one possibility my $realpossible=0; foreach my $id (@possibilities) { my $file=$bighash{'src_'.$id}; - my $canaccess; - if (($donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { - $canaccess = 1; - } else { - $canaccess = &allowed('bre',$file); - } - if ($canaccess) { - my ($mapid,$resid)=split(/\./,$id); - if ($bighash{'map_type_'.$mapid} ne 'page') { - my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid}, - $resid,$thisfn); - if (ref($possibles) eq 'HASH') { - $possibles->{$syval} = 1; - } - if ($checkforblock) { - my @blockers = &has_comm_blocking('bre',$poss_syval,$file); - unless (@blockers > 0) { - $syval = $poss_syval; - $realpossible++; - } - } else { - $syval = $poss_syval; - $realpossible++; - } - } + if (&allowed('bre',$file)) { + my ($mapid,$resid)=split(/\./,$id); + if ($bighash{'map_type_'.$mapid} ne 'page') { + $realpossible++; + $syval=&encode_symb($bighash{'map_id_'.$mapid}, + $resid,$thisfn); + } } } if ($realpossible!=1) { $syval=''; } @@ -11316,7 +10872,7 @@ sub symbread { $syval=''; } } - untie(%bighash); + untie(%bighash) } } if ($syval) { @@ -11469,6 +11025,7 @@ sub rndseed { $which =&get_rand_alg($courseid); } if (defined(&getCODE())) { + if ($which eq '64bit5') { return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username); } elsif ($which eq '64bit4') { @@ -11654,12 +11211,8 @@ sub rndseed_CODE_64bit5 { sub setup_random_from_rndseed { my ($rndseed)=@_; if ($rndseed =~/([,:])/) { - my ($num1,$num2) = map { abs($_); } (split(/[,:]/,$rndseed)); - if ((!$num1) || (!$num2) || ($num1 > 2147483562) || ($num2 > 2147483398)) { - &Math::Random::random_set_seed_from_phrase($rndseed); - } else { - &Math::Random::random_set_seed($num1,$num2); - } + my ($num1,$num2)=split(/[,:]/,$rndseed); + &Math::Random::random_set_seed(abs($num1),abs($num2)); } else { &Math::Random::random_set_seed_from_phrase($rndseed); } @@ -12050,9 +11603,7 @@ sub default_login_domain { sub declutter { my $thisfn=shift; if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } - unless ($thisfn=~m{^/home/httpd/html/priv/}) { - $thisfn=~s{^/home/httpd/html}{}; - } + $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; $thisfn=~s/^\///; $thisfn=~s|^adm/wrapper/||; $thisfn=~s|^adm/coursedocs/showdoc/||; @@ -12179,7 +11730,7 @@ sub get_dns { $alldns{$host} = $protocol; } while (%alldns) { - my ($dns) = sort { $b cmp $a } keys(%alldns); + my ($dns) = keys(%alldns); my $ua=new LWP::UserAgent; $ua->timeout(30); my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); @@ -12187,9 +11738,9 @@ sub get_dns { delete($alldns{$dns}); next if ($response->is_error()); my @content = split("\n",$response->content); - unless ($nocache) { + unless ($nocache) { &do_cache_new('dns',$url,\@content,30*24*60*60); - } + } &$func(\@content,$hashref); return; } @@ -12205,35 +11756,16 @@ sub get_dns { # ------------------------------------------------------Get DNS checksums file sub parse_dns_checksums_tab { my ($lines,$hashref) = @_; - my $lonhost = $perlvar{'lonHostID'}; - my $machine_dom = &Apache::lonnet::host_domain($lonhost); + my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'}); my $loncaparev = &get_server_loncaparev($machine_dom); - my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0]; - my $webconfdir = '/etc/httpd/conf'; - if ($distro =~ /^(ubuntu|debian)(\d+)$/) { - $webconfdir = '/etc/apache2'; - } elsif ($distro =~ /^sles(\d+)$/) { - if ($1 >= 10) { - $webconfdir = '/etc/apache2'; - } - } elsif ($distro =~ /^suse(\d+\.\d+)$/) { - if ($1 >= 10.0) { - $webconfdir = '/etc/apache2'; - } - } my ($release,$timestamp) = split(/\-/,$loncaparev); my (%chksum,%revnum); if (ref($lines) eq 'ARRAY') { chomp(@{$lines}); my $version = shift(@{$lines}); - if ($version eq $release) { + if ($version eq $release) { foreach my $line (@{$lines}) { my ($file,$version,$shasum) = split(/,/,$line); - if ($file =~ m{^/etc/httpd/conf}) { - if ($webconfdir eq '/etc/apache2') { - $file =~ s{^\Q/etc/httpd/conf/\E}{$webconfdir/}; - } - } $chksum{$file} = $shasum; $revnum{$file} = $version; } @@ -12251,7 +11783,7 @@ sub parse_dns_checksums_tab { sub fetch_dns_checksums { my %checksums; my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'}); - my $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'}); + my $loncaparev = &get_server_loncaparev($machine_dom); my ($release,$timestamp) = split(/\-/,$loncaparev); &get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1, \%checksums); @@ -12286,8 +11818,8 @@ sub fetch_dns_checksums { } sub load_domain_tab { - my ($ignore_cache,$nocache) = @_; - &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache); + my ($ignore_cache) = @_; + &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache); my $fh; if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { my @lines = <$fh>; @@ -12373,8 +11905,8 @@ sub fetch_dns_checksums { } sub load_hosts_tab { - my ($ignore_cache,$nocache) = @_; - &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache); + my ($ignore_cache) = @_; + &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache); open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); my @config = <$config>; &parse_hosts_tab(\@config); @@ -12396,8 +11928,7 @@ sub fetch_dns_checksums { } sub all_names { - my ($ignore_cache,$nocache) = @_; - &load_hosts_tab($ignore_cache,$nocache) if (!$loaded); + &load_hosts_tab() if (!$loaded); return %name_to_host; } @@ -12519,7 +12050,7 @@ sub fetch_dns_checksums { } sub get_iphost { - my ($ignore_cache,$nocache) = @_; + my ($ignore_cache) = @_; if (!$ignore_cache) { if (%iphost) { @@ -12543,7 +12074,7 @@ sub fetch_dns_checksums { %old_name_to_ip = %{$ip_info->[1]}; } - my %name_to_host = &all_names($ignore_cache,$nocache); + my %name_to_host = &all_names(); foreach my $name (keys(%name_to_host)) { my $ip; if (!exists($name_to_ip{$name})) { @@ -12568,11 +12099,9 @@ sub fetch_dns_checksums { } push(@{$iphost{$ip}},@{$name_to_host{$name}}); } - unless ($nocache) { - &do_cache_new('iphost','iphost', - [\%iphost,\%name_to_ip,\%lonid_to_ip], - 48*60*60); - } + &do_cache_new('iphost','iphost', + [\%iphost,\%name_to_ip,\%lonid_to_ip], + 48*60*60); return %iphost; } @@ -12637,9 +12166,9 @@ sub all_loncaparevs { return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10 2.11); } -# ------------------------------------------------------- Read loncaparev table +# ---------------------------------------------------------- Read loncaparev table { - sub load_loncaparevs { + sub load_loncaparevs { if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") { if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) { while (my $configline=<$config>) { @@ -12653,7 +12182,7 @@ sub all_loncaparevs { } } -# ----------------------------------------------------- Read serverhostID table +# ---------------------------------------------------------- Read serverhostID table { sub load_serverhomeIDs { if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") { @@ -12745,11 +12274,11 @@ BEGIN { close($config); } -# --------------------------------------------------------- Read loncaparev table +# ---------------------------------------------------------- Read loncaparev table &load_loncaparevs(); -# ------------------------------------------------------- Read serverhostID table +# ---------------------------------------------------------- Read serverhostID table &load_serverhomeIDs(); @@ -12953,7 +12482,7 @@ were new keys. I.E. 1:foo will become 1: Calling convention: my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname); - &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$laststore); + &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname); For more detailed information, see lonnet specific documentation. @@ -13089,29 +12618,13 @@ escaped strings of the action recorded i =item * -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. - +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 - B: access temporarily blocked because of a blocking event in a course. =item * @@ -13163,9 +12676,9 @@ provided for types, will default to retu =item * in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if -user: $uname:$udom has a role in the course: $cdom_$cnum. +user: $uname:$udom has a role in the course: $cdom_$cnum. -Additional optional arguments are: $type (if role checking is to be restricted +Additional optional arguments are: $type (if role checking is to be restricted to certain user status types -- previous (expired roles), active (currently available roles) or future (roles available in the future), and $hideprivileged -- if true will not report course roles for users who @@ -13402,7 +12915,7 @@ values that are the resource value. I b versions are also returned. get_numsuppfiles($cnum,$cdom) : retrieve number of files in a course's -supplemental content area. This routine caches the number of files for +supplemental content area. This routine caches the number of files for 10 minutes. =back @@ -13505,20 +13018,7 @@ will be stored for query =item * -symbread($filename,$donotrecurse,$ignorecachednull,$checkforblock,$possibles) : -return symbolic list entry (all arguments optional). - -Args: filename is the filename (including path) for the file for which a symb -is required; donotrecurse, if true will prevent calls to allowed() being made -to check access status if more than one resource was found in the bighash -(see rev. 1.249) to avoid an infinite loop if an ambiguous resource is part of -a randompick); ignorecachednull, if true will prevent a symb of '' being -returned if $env{$cache_str} is defined as ''; checkforblock if true will -cause possible symbs to be checked to determine if they are subject to content -blocking, if so they will not be included as possible symbs; possibles is a -ref to a hash, which, as a side effect, will be populated with all possible -symbs (content blocking not tested). - +symbread($filename) : return symbolic list entry (filename argument optional); returns the data handle =item * @@ -13528,9 +13028,9 @@ and is a possible symb for the URL in $t resource that the user accessed using /enc/ returns a 1 on success, 0 on failure, user must be in a course, as it assumes the existence of the course initial hash, and uses $env('request.course.id'}. The third -arg is an optional reference to a scalar. If this arg is passed in the +arg is an optional reference to a scalar. If this arg is passed in the call to symbverify, it will be set to 1 if the symb has been set to be -encrypted; otherwise it will be null. +encrypted; otherwise it will be null. =item * @@ -13583,13 +13083,13 @@ expirespread($uname,$udom,$stype,$usymb) devalidate($symb) : devalidate temporary spreadsheet calculations, forcing spreadsheet to reevaluate the resource scores next time. -=item * +=item * can_edit_resource($file,$cnum,$cdom,$resurl,$symb,$group) : determine if current user can edit a particular resource, when viewing in course context. input: six args -- filename (decluttered), course number, course domain, - url, symb (if registered) and group (if this is a + url, symb (if registered) and group (if this is a group item -- e.g., bulletin board, group page etc.). output: array of five scalars -- @@ -13597,15 +13097,15 @@ when viewing in course context. $home -- homeserver of resource (i.e., for author if published, or course if uploaded.). $switchserver -- 1 if server switch will be needed. - $forceedit -- 1 if icon/link should be to go to edit mode + $forceedit -- 1 if icon/link should be to go to edit mode $forceview -- 1 if icon/link should be to go to view mode =item * is_course_upload($file,$cnum,$cdom) -Used in course context to determine if current file was uploaded to -the course (i.e., would be found in /userfiles/docs on the course's +Used in course context to determine if current file was uploaded to +the course (i.e., would be found in /userfiles/docs on the course's homeserver. input: 3 args -- filename (decluttered), course number and course domain. @@ -13619,21 +13119,15 @@ homeserver. =item * -store($storehash,$symb,$namespace,$udom,$uname,$laststore) : stores hash -permanently for this url; hashref needs to be given and should be a \%hashname; -the remaining args aren't required and if they aren't passed or are '' they will -be derived from the env (with the exception of $laststore, which is an -optional arg used when a user's submission is stored in grading). -$laststore is $version=$timestamp, where $version is the most recent version -number retrieved for the corresponding $symb in the $namespace db file, and -$timestamp is the timestamp for that transaction (UNIX time). -$laststore is currently only passed when cstore() is called by -structuretags::finalize_storage(). +store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently +for this url; hashref needs to be given and should be a \%hashname; the +remaining args aren't required and if they aren't passed or are '' they will +be derived from the env =item * -cstore($storehash,$symb,$namespace,$udom,$uname,$laststore) : same as store -but uses critical subroutine +cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but +uses critical subroutine =item * @@ -13656,11 +13150,10 @@ $range should be either an integer '100' =item * -putstore($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog) : +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. If $tolog is true, the transaction is logged in the courselog -with an action=PUTSTORE. +reference =item * @@ -13770,7 +13263,7 @@ server ($udom and $uhome are optional) =item * -get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults +get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults for: authentication, language, quotas, timezone, date locale, and portal URL in the target domain. @@ -13814,7 +13307,7 @@ inststatus: types of institutional affil =over =item -inststatustypes, inststatusorder, inststatusguest +inststatustypes, inststatusorder =back @@ -13825,7 +13318,7 @@ for course's uploaded content. =over =item -canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, +canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, communityquota, textbookquota =back @@ -13836,7 +13329,7 @@ on your servers. =over -=item +=item remotesessions, hostedsessions =back @@ -13844,10 +13337,10 @@ remotesessions, hostedsessions =back In cases where a domain coordinator has never used the "Set Domain Configuration" -utility to create a configuration.db file on a domain's primary library server +utility to create a configuration.db file on a domain's primary library server only the following domain defaults: auth_def, auth_arg_def, lang_def -- corresponding values are authentication type (internal, krb4, krb5, -or localauth), initial password or a kerberos realm, language (e.g., en-us) -- +or localauth), initial password or a kerberos realm, language (e.g., en-us) -- will be available. Values are retrieved from cache (if current), unless the optional $ignore_cache arg is true, or from domain's configuration.db (if available), or lastly from values in lonTabs/dns_domain,tab, or lonTabs/domain.tab. @@ -14079,8 +13572,7 @@ filelocation except for hrefs =item * -declutter() : declutters URLs -- remove beginning slashes, 'res' etc. -also removes beginning /home/httpd/html unless /priv/ follows it. +declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc) =back @@ -14275,8 +13767,8 @@ Returns: get_timebased_id(): -Attempts to get a unique timestamp-based suffix for use with items added to a -course via the Course Editor (e.g., folders, composite pages, +Attempts to get a unique timestamp-based suffix for use with items added to a +course via the Course Editor (e.g., folders, composite pages, group bulletin boards). Args: (first three required; six others optional) @@ -14287,24 +13779,24 @@ Args: (first three required; six others 2. keyid (alphanumeric): name of temporary locking key in hash, e.g., num, boardids -3. namespace: name of gdbm file used to store suffixes already assigned; +3. namespace: name of gdbm file used to store suffixes already assigned; file will be named nohist_namespace.db 4. cdom: domain of course; default is current course domain from %env 5. cnum: course number; default is current course number from %env -6. idtype: set to concat if an additional digit is to be appended to the +6. idtype: set to concat if an additional digit is to be appended to the unix timestamp to form the suffix, if the plain timestamp is already - in use. Default is to not do this, but simply increment the unix + in use. Default is to not do this, but simply increment the unix timestamp by 1 until a unique key is obtained. 7. who: holder of locking key; defaults to user:domain for user. -8. locktries: number of attempts to obtain a lock (sleep of 1s before +8. locktries: number of attempts to obtain a lock (sleep of 1s before retrying); default is 3. -9. maxtries: number of attempts to obtain a unique suffix; default is 20. +9. maxtries: number of attempts to obtain a unique suffix; default is 20. Returns: