--- loncom/lonnet/perl/lonnet.pm 2013/03/18 00:30:46 1.1172.2.21 +++ loncom/lonnet/perl/lonnet.pm 2012/09/04 20:48:05 1.1190 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1172.2.21 2013/03/18 00:30:46 raeburn Exp $ +# $Id: lonnet.pm,v 1.1190 2012/09/04 20:48:05 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -75,7 +75,10 @@ use LWP::UserAgent(); use HTTP::Date; use Image::Magick; -use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $apache + +use Encode; + +use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease %managerstab); @@ -97,6 +100,7 @@ use File::MMagic; use LONCAPA qw(:DEFAULT :match); use LONCAPA::Configuration; use LONCAPA::lonmetadata; +use LONCAPA::Lond; use File::Copy; @@ -108,6 +112,7 @@ require Exporter; our @ISA = qw (Exporter); our @EXPORT = qw(%env); + # ------------------------------------ Logging (parameters, docs, slots, roles) { my $logid; @@ -122,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); } } @@ -629,15 +634,6 @@ sub check_for_valid_session { || !defined($disk_env{'user.domain'})) { return undef; } - - if (($r->user() eq '') && ($apache >= 2.4)) { - if ($disk_env{'user.domain'} eq $r->dir_config('lonDefDomain')) { - $r->user($disk_env{'user.name'}); - } else { - $r->user($disk_env{'user.name'}.':'.$disk_env{'user.domain'}); - } - } - return $handle; } @@ -1244,8 +1240,8 @@ sub get_lonbalancer_config { sub check_loadbalancing { my ($uname,$udom) = @_; - my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom, - $rule_in_effect,$offloadto,$otherserver); + my ($is_balancer,$dom_in_use,$homeintdom,$rule_in_effect, + $offloadto,$otherserver); my $lonhost = $perlvar{'lonHostID'}; my @hosts = ¤t_machine_ids(); my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); @@ -1270,8 +1266,14 @@ sub check_loadbalancing { } } if (ref($result) eq 'HASH') { - ($is_balancer,$currtargets,$currrules) = - &check_balancer_result($result,@hosts); + my $currbalancer = $result->{'lonhost'}; + my $currtargets = $result->{'targets'}; + my $currrules = $result->{'rules'}; + if ($currbalancer ne '') { + if (grep(/^\Q$currbalancer\E$/,@hosts)) { + $is_balancer = 1; + } + } if ($is_balancer) { if (ref($currrules) eq 'HASH') { if ($homeintdom) { @@ -1329,9 +1331,12 @@ sub check_loadbalancing { } } if (ref($result) eq 'HASH') { - ($is_balancer,$currtargets,$currrules) = - &check_balancer_result($result,@hosts); - if ($is_balancer) { + my $currbalancer = $result->{'lonhost'}; + my $currtargets = $result->{'targets'}; + my $currrules = $result->{'rules'}; + + if ($currbalancer eq $lonhost) { + $is_balancer = 1; if (ref($currrules) eq 'HASH') { if ($currrules->{'_LC_internetdom'} ne '') { $rule_in_effect = $currrules->{'_LC_internetdom'}; @@ -1385,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}); } } @@ -1395,32 +1400,6 @@ sub check_loadbalancing { return ($is_balancer,$otherserver); } -sub check_balancer_result { - my ($result,@hosts) = @_; - my ($is_balancer,$currtargets,$currrules); - if (ref($result) eq 'HASH') { - if ($result->{'lonhost'} ne '') { - my $currbalancer = $result->{'lonhost'}; - if (grep(/^\Q$currbalancer\E$/,@hosts)) { - $is_balancer = 1; - $currtargets = $result->{'targets'}; - $currrules = $result->{'rules'}; - } - } else { - foreach my $key (keys(%{$result})) { - if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) && - (ref($result->{$key}) eq 'HASH')) { - $is_balancer = 1; - $currrules = $result->{$key}{'rules'}; - $currtargets = $result->{$key}{'targets'}; - last; - } - } - } - } - return ($is_balancer,$currtargets,$currrules); -} - sub get_loadbalancer_targets { my ($rule_in_effect,$currtargets,$uname,$udom) = @_; my $offloadto; @@ -2004,9 +1983,8 @@ sub get_domain_defaults { } } if (ref($domconfig{'coursedefaults'}) eq 'HASH') { - if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') { - $domdefaults{'officialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'official'}; - $domdefaults{'unofficialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'unofficial'}; + foreach my $item ('canuse_pdfforms') { + $domdefaults{$item} = $domconfig{'coursedefaults'}{$item}; } } if (ref($domconfig{'usersessions'}) eq 'HASH') { @@ -2615,10 +2593,13 @@ sub ssi { $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; } } @@ -2647,253 +2628,6 @@ sub allowuploaded { &Apache::lonnet::appenv(\%httpref); } -# -# 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 -# Functions. -# (b) When displaying folder contents in course editor, used to determine if -# "Edit" link will be displayed alongside resource. -# -# 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 -- -# $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 -# $forceview -- 1 if icon/link should be to go to view mode -# - -sub can_edit_resource { - my ($file,$cnum,$cdom,$resurl,$symb,$group) = @_; - my ($cfile,$home,$switchserver,$forceedit,$forceview,$uploaded,$incourse); -# -# For aboutme pages user can only edit his/her own. -# - if ($resurl =~ m{^/?adm/($match_domain)/($match_username)/aboutme$}) { - my ($sdom,$sname) = ($1,$2); - if (($sdom eq $env{'user.domain'}) && ($sname eq $env{'user.name'})) { - $home = $env{'user.home'}; - $cfile = $resurl; - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - return ($cfile,$home,$switchserver,$forceedit,$forceview); - } else { - return; - } - } - - if ($env{'request.course.id'}) { - my $crsedit = &Apache::lonnet::allowed('mdc',$env{'request.course.id'}); - if ($group ne '') { -# if this is a group homepage or group bulletin board, check group privs - my $allowed = 0; - if ($resurl =~ m{^/?adm/$cdom/$cnum/$group/smppg$}) { - if ((&allowed('mdg',$env{'request.course.id'}. - ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) || - (&allowed('mgh',$env{'request.course.id'}.'/'.$group)) || $crsedit) { - $allowed = 1; - } - } elsif ($resurl =~ m{^/?adm/$cdom/$cnum/\d+/bulletinboard$}) { - if ((&allowed('mdg',$env{'request.course.id'}.($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) || - (&allowed('cgb',$env{'request.course.id'}.'/'.$group)) || $crsedit) { - $allowed = 1; - } - } - if ($allowed) { - $home=&homeserver($cnum,$cdom); - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - $cfile = $resurl; - } else { - return; - } - } else { - if ($resurl =~ m{^/?adm/viewclasslist$}) { - unless (&Apache::lonnet::allowed('opa',$env{'request.course.id'})) { - return; - } - } elsif (!$crsedit) { -# -# No edit allowed where CC has switched to student role. -# - return; - } - } - } - - if ($file ne '') { - if (($cnum =~ /$match_courseid/) && ($cdom =~ /$match_domain/)) { - if (&is_course_upload($file,$cnum,$cdom)) { - $uploaded = 1; - $incourse = 1; - if ($file =~/\.(htm|html|css|js|txt)$/) { - $cfile = &hreflocation('',$file); - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - } - } elsif ($resurl =~ m{^/public/$cdom/$cnum/syllabus}) { - $incourse = 1; - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - $cfile = $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'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - $cfile = $resurl; - } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem') { - $incourse = 1; - $cfile = $resurl.'/smpedit'; - } elsif ($resurl =~ m{^/adm/wrapper/ext/}) { - $incourse = 1; - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - $cfile = $resurl; - } elsif ($resurl =~ m{^/?adm/viewclasslist$}) { - $incourse = 1; - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - $cfile = ($resurl =~ m{^/} ? $resurl : "/$resurl"); - } - } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') { - my $template = '/res/lib/templates/simpleproblem.problem'; - if (&is_on_map($template)) { - $incourse = 1; - $forceview = 1; - $cfile = $template; - } - } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) { - $incourse = 1; - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - $cfile = $resurl; - } elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) { - $incourse = 1; - $forceview = 1; - if ($symb) { - my ($map,$id,$res)=&decode_symb($symb); - $env{'request.symb'} = $symb; - $cfile = &clutter($res); - } else { - $cfile = $env{'form.suppurl'}; - $cfile =~ s{^http://}{}; - $cfile = '/adm/wrapper/ext/'.$cfile; - } - } - } - if ($uploaded || $incourse) { - $home=&homeserver($cnum,$cdom); - } elsif ($file !~ m{/$}) { - $file=~s{^(priv/$match_domain/$match_username)}{/$1}; - $file=~s{^($match_domain/$match_username)}{/priv/$1}; - # Check that the user has permission to edit this resource - my $setpriv = 1; - my ($cfuname,$cfudom)=&constructaccess($file,$setpriv); - if (defined($cfudom)) { - $home=&homeserver($cfuname,$cfudom); - $cfile=$file; - } - } - if (($cfile ne '') && (!$incourse || $uploaded) && - (($home ne '') && ($home ne 'no_host'))) { - my @ids=¤t_machine_ids(); - unless (grep(/^\Q$home\E$/,@ids)) { - $switchserver=1; - } - } - } - return ($cfile,$home,$switchserver,$forceedit,$forceview); -} - -sub is_course_upload { - my ($file,$cnum,$cdom) = @_; - my $uploadpath = &LONCAPA::propath($cdom,$cnum); - $uploadpath =~ s{^\/}{}; - if (($file =~ m{^\Q$uploadpath\E/userfiles/(docs|supplemental)/}) || - ($file =~ m{^userfiles/\Q$cdom\E/\Q$cnum\E/(docs|supplemental)/})) { - return 1; - } - return; -} - -sub in_course { - my ($udom,$uname,$cdom,$cnum,$type,$hideprivileged) = @_; - if ($hideprivileged) { - my $skipuser; - if (&privileged($uname,$udom)) { - $skipuser = 1; - my %coursehash = &coursedescription($cdom.'_'.$cnum); - if ($coursehash{'nothideprivileged'}) { - foreach my $item (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { - my $user; - if ($item =~ /:/) { - $user = $item; - } else { - $user = join(':',split(/[\@]/,$item)); - } - if ($user eq $uname.':'.$udom) { - undef($skipuser); - last; - } - } - } - if ($skipuser) { - return 0; - } - } - } - $type ||= 'any'; - if (!defined($cdom) || !defined($cnum)) { - my $cid = $env{'request.course.id'}; - $cdom = $env{'course.'.$cid.'.domain'}; - $cnum = $env{'course.'.$cid.'.num'}; - } - my $typesref; - if (($type eq 'any') || ($type eq 'all')) { - $typesref = ['active','previous','future']; - } elsif ($type eq 'previous' || $type eq 'future') { - $typesref = [$type]; - } - my %roles = &get_my_roles($uname,$udom,'userroles', - $typesref,undef,[$cdom]); - my ($tmp) = keys(%roles); - return 0 if ($tmp =~ /^(con_lost|error|no_such_host)/i); - my @course_roles = grep(/^\Q$cnum\E:\Q$cdom\E:/, keys(%roles)); - if (@course_roles > 0) { - return 1; - } - return 0; -} - # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course # input: action, courseID, current domain, intended # path to file, source of file, instruction to parse file for objects, @@ -3184,9 +2918,7 @@ sub userfileupload { $codebase,$thumbwidth,$thumbheight, $resizewidth,$resizeheight,$context,$mimetype); } else { - if ($env{'form.folder'}) { - $fname=$env{'form.folder'}.'/'.$fname; - } + $fname=$env{'form.folder'}.'/'.$fname; return &process_coursefile('uploaddoc',$docuname,$docudom, $fname,$formname,$parser, $allfiles,$codebase,$mimetype); @@ -4132,18 +3864,32 @@ sub courseiddump { if (($domfilter eq '') || (&host_domain($tryserver) eq $domfilter)) { - my $rep = - &reply('courseiddump:'.&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, - $tryserver); + my $rep; + 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))); + } else { + $rep = &reply('courseiddump:'.&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, + $tryserver); + } + my @pairs=split(/\&/,$rep); foreach my $item (@pairs) { my ($key,$value)=split(/\=/,$item,2); @@ -5053,11 +4799,9 @@ sub rolesinit { } sub set_arearole { - my ($trole,$area,$tstart,$tend,$domain,$username,$nolog) = @_; - unless ($nolog) { + my ($trole,$area,$tstart,$tend,$domain,$username) = @_; # log the associated role with the area - &userrolelog($trole,$username,$domain,$area,$tstart,$tend); - } + &userrolelog($trole,$username,$domain,$area,$tstart,$tend); return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend); } @@ -5326,7 +5070,7 @@ sub set_adhoc_privileges { my $area = '/'.$dcdom.'/'.$pickedcourse; my $spec = $role.'.'.$area; my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'}, - $env{'user.name'},1); + $env{'user.name'}); my %ccrole = (); &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area); my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole); @@ -5389,12 +5133,37 @@ sub del { # -------------------------------------------------------------- dump interface +sub unserialize { + my ($rep, $escapedkeys) = @_; + + 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} = Apache::lonnet::thaw_unescape($value); + } + #return %returnhash; + return \%returnhash; +} + +# see Lond::dump_with_regexp +# if $escapedkeys hash keys won't get unescaped. sub dump { - my ($namespace,$udomain,$uname,$regexp,$range)=@_; + my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_; if (!$udomain) { $udomain=$env{'user.domain'}; } if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); + my $reply; + if (grep { $_ eq $uhome } current_machine_ids()) { + # user is hosted on this machine + $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain, + $uname, $namespace, $regexp, $range)), $loncaparevs{$uhome}); + return %{unserialize($reply, $escapedkeys)}; + } if ($regexp) { $regexp=&escape($regexp); } else { @@ -5406,7 +5175,8 @@ sub dump { if (!($rep =~ /^error/ )) { foreach my $item (@pairs) { my ($key,$value)=split(/=/,$item,2); - $key = &unescape($key); + $key = unescape($key) unless $escapedkeys; + #$key = &unescape($key); next if ($key =~ /^error: 2 /); $returnhash{$key}=&thaw_unescape($value); } @@ -5419,23 +5189,9 @@ sub dump { sub dumpstore { my ($namespace,$udomain,$uname,$regexp,$range)=@_; - if (!$udomain) { $udomain=$env{'user.domain'}; } - if (!$uname) { $uname=$env{'user.name'}; } - my $uhome=&homeserver($uname,$udomain); - if ($regexp) { - $regexp=&escape($regexp); - } else { - $regexp='.'; - } - my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); - my @pairs=split(/\&/,$rep); - my %returnhash=(); - foreach my $item (@pairs) { - my ($key,$value)=split(/=/,$item,2); - next if ($key =~ /^error: 2 /); - $returnhash{$key}=&thaw_unescape($value); - } - return %returnhash; + # same as dump but keys must be escaped. They may contain colon separated + # lists of values that may themself contain colons (e.g. symbs). + return &dump($namespace, $udomain, $uname, $regexp, $range, 1); } # -------------------------------------------------------------- keys interface @@ -5461,7 +5217,15 @@ sub currentdump { $sdom = $env{'user.domain'} if (! defined($sdom)); $sname = $env{'user.name'} if (! defined($sname)); my $uhome = &homeserver($sname,$sdom); - my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); + my $rep; + + if (grep { $_ eq $uhome } current_machine_ids()) { + $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname, + $courseid))); + } else { + $rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); + } + return if ($rep =~ /^(error:|no_such_host)/); # my %returnhash=(); @@ -5704,88 +5468,6 @@ sub tmpdel { return &reply("tmpdel:$token",$server); } -# ------------------------------------------------------------ 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 '')) { - return ('','ok','invalid call to get suffix'); - } - -# set defaults for any optional args for which values were not supplied - if ($who eq '') { - $who = $env{'user.name'}.':'.$env{'user.domain'}; - } - if (!$locktries) { - $locktries = 3; - } - if (!$maxtries) { - $maxtries = 10; - } - - if (($cdom eq '') || ($cnum eq '')) { - if ($env{'request.course.id'}) { - $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; - $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; - } - if (($cdom eq '') || ($cnum eq '')) { - return ('','ok','call to get suffix not in course context'); - } - } - -# construct locking item - my $lockhash = { - $prefix."\0".'locked_'.$keyid => $who, - }; - my $tries = 0; - -# attempt to get lock on nohist_$namespace file - my $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum); - while (($gotlock ne 'ok') && $tries <$locktries) { - $tries ++; - sleep 1; - $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum); - } - -# attempt to get unique identifier, based on current timestamp - if ($gotlock eq 'ok') { - my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix); - my $id = time; - $newid = $id; - my $idtries = 0; - while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) { - if ($idtype eq 'concat') { - $newid = $id.$idtries; - } else { - $newid ++; - } - $idtries ++; - } - if (!exists($inuse{$prefix."\0".$newid})) { - my %new_item = ( - $prefix."\0".$newid => $who, - ); - my $putresult = &Apache::lonnet::put('nohist_'.$namespace,\%new_item, - $cdom,$cnum); - if ($putresult ne 'ok') { - undef($newid); - $error = 'error saving new item: '.$putresult; - } - } else { - $error = ('error: no unique suffix available for the new item '); - } -# remove lock - my @del_lock = ($prefix."\0".'locked_'.$keyid); - $dellock = &Apache::lonnet::del('nohist_'.$namespace,\@del_lock,$cdom,$cnum); - } else { - $error = "error: could not obtain lockfile\n"; - $dellock = 'ok'; - } - return ($newid,$dellock,$error); -} - # -------------------------------------------------- portfolio access checking sub portfolio_access { @@ -6074,7 +5756,7 @@ sub usertools_access { my ($toolstatus,$inststatus,$envkey); if ($context eq 'requestauthor') { - $envkey = $context; + $envkey = $context; } else { $envkey = $context.'.'.$tool; } @@ -6812,73 +6494,6 @@ sub allowed { return 'F'; } -# ------------------------------------------- Check construction space access - -sub constructaccess { - my ($url,$setpriv)=@_; - -# We do not allow editing of previous versions of files - if ($url=~/\.(\d+)\.(\w+)$/) { return ''; } - -# Get username and domain from URL - my ($ownername,$ownerdomain,$ownerhome); - - ($ownerdomain,$ownername) = - ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)/}); - -# The URL does not really point to any authorspace, forget it - unless (($ownername) && ($ownerdomain)) { return ''; } - -# Now we need to see if the user has access to the authorspace of -# $ownername at $ownerdomain - - if (($ownername eq $env{'user.name'}) && ($ownerdomain eq $env{'user.domain'})) { -# Real author for this? - $ownerhome = $env{'user.home'}; - if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) { - return ($ownername,$ownerdomain,$ownerhome); - } - } else { -# Co-author for this? - if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) || - exists($env{'user.priv.aa./'.$ownerdomain.'/'.$ownername.'./'}) ) { - $ownerhome = &homeserver($ownername,$ownerdomain); - return ($ownername,$ownerdomain,$ownerhome); - } - } - -# We don't have any access right now. If we are not possibly going to do anything about this, -# we might as well leave - unless ($setpriv) { return ''; } - -# Backdoor access? - my $allowed=&allowed('eco',$ownerdomain); -# Nope - unless ($allowed) { return ''; } -# Looks like we may have access, but could be locked by the owner of the construction space - if ($allowed eq 'U') { - my %blocked=&get('environment',['domcoord.author'], - $ownerdomain,$ownername); -# Is blocked by owner - if ($blocked{'domcoord.author'} eq 'blocked') { return ''; } - } - if (($allowed eq 'F') || ($allowed eq 'U')) { -# Grant temporary access - my $then=$env{'user.login.time'}; - my $update=$env{'user.update.time'}; - if (!$update) { $update = $then; } - my $refresh=$env{'user.refresh.time'}; - if (!$refresh) { $refresh = $update; } - my $now = time; - &check_adhoc_privs($ownerdomain,$ownername,$update,$refresh, - $now,'ca','constructaccess'); - $ownerhome = &homeserver($ownername,$ownerdomain); - return($ownername,$ownerdomain,$ownerhome); - } -# No business here - return ''; -} - sub get_comm_blocks { my ($cdom,$cnum) = @_; if ($cdom eq '' || $cnum eq '') { @@ -7404,8 +7019,8 @@ sub auto_validate_instcode { } $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'. &escape($instcode).':'.&escape($owner),$homeserver)); - my ($outcome,$description,$defaultcredits) = map { &unescape($_); } split('&',$response,3); - return ($outcome,$description,$defaultcredits); + my ($outcome,$description) = map { &unescape($_); } split('&',$response,2); + return ($outcome,$description); } sub auto_create_password { @@ -7944,7 +7559,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 = ''; @@ -7952,13 +7567,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; } @@ -8027,16 +7642,16 @@ sub assignrole { # log new user role if status is ok if ($answer eq 'ok') { &userrolelog($role,$uname,$udom,$url,$start,$end); +# for course roles, perform group memberships changes triggered by role change. + unless ($role =~ /^gr/) { + &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, + $origstart,$selfenroll,$context); + } if (($role eq 'cc') || ($role eq 'in') || ($role eq 'ep') || ($role eq 'ad') || ($role eq 'ta') || ($role eq 'st') || ($role=~/^cr/) || ($role eq 'gr') || ($role eq 'co')) { -# for course roles, perform group memberships changes triggered by role change. - unless ($role =~ /^gr/) { - &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, - $origstart,$selfenroll,$context); - } &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, $selfenroll,$context); } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') || @@ -8045,7 +7660,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); @@ -8345,7 +7960,7 @@ sub modifyuser { sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid, - $selfenroll,$context,$inststatus,$credits)=@_; + $selfenroll,$context,$inststatus)=@_; if (!$cid) { unless ($cid=$env{'request.course.id'}) { return 'not_in_class'; @@ -8360,13 +7975,12 @@ sub modifystudent { # students environment $uid = undef if (!$forceid); $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, - $gene,$usec,$end,$start,$type,$locktype, - $cid,$selfenroll,$context,$credits); + $gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context); return $reply; } sub modify_student_enrollment { - my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context,$credits) = @_; + my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context) = @_; my ($cdom,$cnum,$chome); if (!$cid) { unless ($cid=$env{'request.course.id'}) { @@ -8413,7 +8027,7 @@ sub modify_student_enrollment { my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum); my $reply=cput('classlist', {$user => - join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits) }, + join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) }, $cdom,$cnum); if (($reply eq 'ok') || ($reply eq 'delayed')) { &devalidate_getsection_cache($udom,$uname,$cid); @@ -9898,7 +9512,7 @@ sub metadata { # if it is a non metadata possible uri return quickly if (($uri eq '') || (($uri =~ m|^/*adm/|) && - ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard)$})) || + ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) || ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { return undef; } @@ -10276,78 +9890,6 @@ sub gettitle { return $title; } -sub getdocspath { - my ($symb) = @_; - my $path; - if ($symb) { - my ($mapurl,$id,$resurl) = &decode_symb($symb); - if ($resurl=~/\.(sequence|page)$/) { - $mapurl=$resurl; - } elsif ($resurl eq 'adm/navmaps') { - $mapurl=$env{'course.'.$env{'request.course.id'}.'.url'}; - } - my $mapresobj; - my $navmap = Apache::lonnavmaps::navmap->new(); - if (ref($navmap)) { - $mapresobj = $navmap->getResourceByUrl($mapurl); - } - $mapurl=~s{^.*/([^/]+)\.(\w+)$}{$1}; - my $type=$2; - if (ref($mapresobj)) { - my $pcslist = $mapresobj->map_hierarchy(); - if ($pcslist ne '') { - foreach my $pc (split(/,/,$pcslist)) { - next if ($pc <= 1); - my $res = $navmap->getByMapPc($pc); - if (ref($res)) { - my $thisurl = $res->src(); - $thisurl=~s{^.*/([^/]+)\.\w+$}{$1}; - my $thistitle = $res->title(); - $path .= '&'. - &Apache::lonhtmlcommon::entity_encode($thisurl).'&'. - &Apache::lonhtmlcommon::entity_encode($thistitle). - ':'.$res->randompick(). - ':'.$res->randomout(). - ':'.$res->encrypted(). - ':'.$res->randomorder(). - ':'.$res->is_page(); - } - } - } - $path =~ s/^\&//; - my $maptitle = $mapresobj->title(); - if ($mapurl eq 'default') { - $maptitle = 'Main Course Documents'; - } - $path .= ($path ne '')? '&' : ''. - &Apache::lonhtmlcommon::entity_encode($mapurl).'&'. - &Apache::lonhtmlcommon::entity_encode($maptitle). - ':'.$mapresobj->randompick(). - ':'.$mapresobj->randomout(). - ':'.$mapresobj->encrypted(). - ':'.$mapresobj->randomorder(). - ':'.$mapresobj->is_page(); - } else { - my $maptitle = &gettitle($mapurl); - my $ispage; - if ($mapurl =~ /\.page$/) { - $ispage = 1; - } - if ($mapurl eq 'default') { - $maptitle = 'Main Course Documents'; - } - $path = &Apache::lonhtmlcommon::entity_encode($mapurl).'&'. - &Apache::lonhtmlcommon::entity_encode($maptitle).':::::'.$ispage; - } - unless ($mapurl eq 'default') { - $path = 'default&'. - &Apache::lonhtmlcommon::entity_encode('Main Course Documents'). - ':::::&'.$path; - } - } - return $path; -} - sub get_slot { my ($which,$cnum,$cdom)=@_; if (!$cnum || !$cdom) { @@ -10495,46 +10037,34 @@ sub symbverify { if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', &GDBM_READER(),0640)) { - my $noclutter; if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) { $thisurl =~ s/\?.+$//; - if ($map =~ m{^uploaded/.+\.page$}) { - $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://}; - $thisurl =~ s{^\Qhttp://https://\E}{https://}; - $noclutter = 1; - } - } - my $ids; - if ($noclutter) { - $ids=$bighash{'ids_'.$thisurl}; - } else { - $ids=$bighash{'ids_'.&clutter($thisurl)}; } + my $ids=$bighash{'ids_'.&clutter($thisurl)}; unless ($ids) { - my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl; + my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl; $ids=$bighash{$idkey}; } if ($ids) { # ------------------------------------------------------------------- Has ID(s) - if ($thisfn =~ m{^/adm/wrapper/ext/}) { - $symb =~ s/\?.+$//; - } foreach my $id (split(/\,/,$ids)) { my ($mapid,$resid)=split(/\./,$id); + if ($thisfn =~ m{^/adm/wrapper/ext/}) { + $symb =~ s/\?.+$//; + } if ( &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) eq $symb) { 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; - last; - } - } - } + $okay=1; + } + } + } } untie(%bighash); } @@ -10607,18 +10137,18 @@ sub deversion { sub symbread { my ($thisfn,$donotrecurse)=@_; - my $cache_str; - if ($thisfn ne '') { - $cache_str='request.symbread.cached.'.$thisfn; - if ($env{$cache_str} ne '') { + my $cache_str='request.symbread.cached.'.$thisfn; + if (defined($env{$cache_str})) { + if (($thisfn) || ($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 @@ -10846,6 +10376,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') { @@ -11528,12 +11059,12 @@ sub goodbye { } sub get_dns { - my ($url,$func,$ignore_cache,$nocache,$hashref) = @_; + my ($url,$func,$ignore_cache) = @_; if (!$ignore_cache) { my ($content,$cached)= &Apache::lonnet::is_cached_new('dns',$url); if ($cached) { - &$func($content,$hashref); + &$func($content); return; } } @@ -11558,10 +11089,8 @@ sub get_dns { delete($alldns{$dns}); next if ($response->is_error()); my @content = split("\n",$response->content); - unless ($nocache) { - &Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60); - } - &$func(\@content,$hashref); + &Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60); + &$func(\@content); return; } close($config); @@ -11569,62 +11098,9 @@ sub get_dns { &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab"); my @content = <$config>; - &$func(\@content,$hashref); - return; -} - -# ------------------------------------------------------Get DNS checksums file -sub parse_dns_checksums_tab { - my ($lines,$hashref) = @_; - my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'}); - my $loncaparev = &get_server_loncaparev($machine_dom); - my ($release,$timestamp) = split(/\-/,$loncaparev); - my (%chksum,%revnum); - if (ref($lines) eq 'ARRAY') { - chomp(@{$lines}); - my $versions = shift(@{$lines}); - my %supported; - if ($versions =~ /^VERSIONS\:([\w\.\,]+)$/) { - my $releaseslist = $1; - if ($releaseslist =~ /,/) { - map { $supported{$_} = 1; } split(/,/,$releaseslist); - } elsif ($releaseslist) { - $supported{$releaseslist} = 1; - } - } - if ($supported{$release}) { - my $matchthis = 0; - foreach my $line (@{$lines}) { - if ($line =~ /^(\d[\w\.]+)$/) { - if ($matchthis) { - last; - } elsif ($1 eq $release) { - $matchthis = 1; - } - } elsif ($matchthis) { - my ($file,$version,$shasum) = split(/,/,$line); - $chksum{$file} = $shasum; - $revnum{$file} = $version; - } - } - if (ref($hashref) eq 'HASH') { - %{$hashref} = ( - sums => \%chksum, - versions => \%revnum, - ); - } - } - } + &$func(\@content); return; } - -sub fetch_dns_checksums { - my %checksums; - &get_dns('/adm/dns/checksums',\&parse_dns_checksums_tab,1,1, - \%checksums); - return \%checksums; -} - # ------------------------------------------------------------ Read domain file { my $loaded; @@ -12162,17 +11638,6 @@ $readit=1; if ($test != 0) { $_64bit=1; } else { $_64bit=0; } &logthis(" Detected 64bit platform ($_64bit)"); } - - { - eval { - ($apache) = - (Apache2::ServerUtil::get_server_version() =~ m{Apache/(\d+\.\d+)}); - }; - if ($@) { - $apache = 1.3; - } - } - } } @@ -12460,21 +11925,6 @@ allowed($priv,$uri,$symb,$role) : check =item * -constructaccess($url,$setpriv) : check for access to construction space URL - -See if the owner domain and name in the URL match those in the -expected environment. If so, return three element list -($ownername,$ownerdomain,$ownerhome). - -Otherwise return the null string. - -If second argument 'setpriv' is true, it assigns the privileges, -and returns the same three element list, unless the owner has -blocked "ad hoc" Domain Coordinator access to the Author Space, -in which case the null string is returned. - -=item * - definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom role rolename set privileges in format of lonTabs/roles.tab for system, domain, and course level @@ -12505,17 +11955,6 @@ of role statuses (active, future or prev to restrict the list of roles reported. If no array ref is provided for types, will default to return only active roles. -=item * - -in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if -user: $uname:$udom has a role in the course: $cdom_$cnum. - -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 -have active Domain Coordinator or Super User roles. - =back =head2 User Modification @@ -12608,9 +12047,7 @@ Inputs: =item B<$context> role change context (shown in User Management Logs display in a course) -=item B<$inststatus> institutional status of user - : separated string of escaped status types - -=item B<$credits> Number of credits student will earn from this class - only needs to be supplied if value needs to be different from default credits for class. +=item B<$inststatus> institutional status of user - : separated string of escaped status types =back @@ -12655,8 +12092,6 @@ Inputs: =item $context -=item $credits, number of credits student will earn from this class - =back @@ -12722,6 +12157,7 @@ data base, returning a hash that is keye values that are the resource value. I believe that the timestamps and versions are also returned. + =back =head2 Course Modification @@ -12827,9 +12263,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 * @@ -12882,34 +12318,6 @@ expirespread($uname,$udom,$stype,$usymb) devalidate($symb) : devalidate temporary spreadsheet calculations, forcing spreadsheet to reevaluate the resource scores next time. -=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 - group item -- e.g., bulletin board, group page etc.). - - 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 - $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 -homeserver. - - input: 3 args -- filename (decluttered), course number and course domain. - output: boolean -- 1 if file was uploaded. - =back =head2 Storing/Retreiving Data @@ -13465,8 +12873,6 @@ Internal notes: Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays. -=item * - modify_access_controls(): Modifies access controls for a portfolio file @@ -13484,51 +12890,7 @@ Returns: 3. reference to hash of any new or updated access controls. 4. reference to hash used to map incoming IDs to uniqueIDs assigned to control. key = integer (inbound ID) - value = uniqueID - -=item * - -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, -group bulletin boards). - -Args: (first three required; six others optional) - -1. prefix (alphanumeric): of keys in hash, e.g., suppsequence, docspage, - docssequence, or name of group - -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; - 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 - 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 - 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 - retrying); default is 3. - -9. maxtries: number of attempts to obtain a unique suffix; default is 20. - -Returns: - -1. suffix obtained (numeric) - -2. result of deleting locking key (ok if deleted, or lock never obtained) - -3. error: contains (localized) error message if an error occurred. - + value = uniqueID =back