--- loncom/lonnet/perl/lonnet.pm 2013/03/18 00:30:46 1.1172.2.21 +++ loncom/lonnet/perl/lonnet.pm 2013/08/04 03:00:12 1.1172.2.30 @@ -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.1172.2.30 2013/08/04 03:00:12 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -97,6 +97,7 @@ use File::MMagic; use LONCAPA qw(:DEFAULT :match); use LONCAPA::Configuration; use LONCAPA::lonmetadata; +use LONCAPA::Lond; use File::Copy; @@ -1575,6 +1576,36 @@ sub idput { } } +# ---------------------------------------- Delete unwanted IDs from ids.db file + +sub iddel { + my ($udom,$idshashref,$uhome)=@_; + my %result=(); + unless (ref($idshashref) eq 'HASH') { + return %result; + } + my %servers=(); + while (my ($id,$uname) = each(%{$idshashref})) { + my $uhom; + if ($uhome) { + $uhom = $uhome; + } else { + $uhom=&homeserver($uname,$udom); + } + if ($uhom ne 'no_host') { + if ($servers{$uhom}) { + $servers{$uhom}.='&'.&escape($id); + } else { + $servers{$uhom}=&escape($id); + } + } + } + foreach my $server (keys(%servers)) { + $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome); + } + return %result; +} + # ------------------------------dump from db file owned by domainconfig user sub dump_dom { my ($namespace, $udom, $regexp) = @_; @@ -1982,13 +2013,16 @@ sub get_domain_defaults { $domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'}; } else { $domdefaults{'defaultquota'} = $domconfig{'quotas'}; - } + } my @usertools = ('aboutme','blog','webdav','portfolio'); foreach my $item (@usertools) { if (ref($domconfig{'quotas'}{$item}) eq 'HASH') { $domdefaults{$item} = $domconfig{'quotas'}{$item}; } } + if (ref($domconfig{'quotas'}{'authorquota'}) eq 'HASH') { + $domdefaults{'authorquota'} = $domconfig{'quotas'}{'authorquota'}; + } } if (ref($domconfig{'requestcourses'}) eq 'HASH') { foreach my $item ('official','unofficial','community') { @@ -2008,6 +2042,11 @@ sub get_domain_defaults { $domdefaults{'officialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'official'}; $domdefaults{'unofficialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'unofficial'}; } + 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'}; + } } if (ref($domconfig{'usersessions'}) eq 'HASH') { if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') { @@ -2017,8 +2056,7 @@ sub get_domain_defaults { $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'}; } } - &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, - $cachetime); + &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime); return %domdefaults; } @@ -2849,9 +2887,13 @@ sub in_course { my ($udom,$uname,$cdom,$cnum,$type,$hideprivileged) = @_; if ($hideprivileged) { my $skipuser; - if (&privileged($uname,$udom)) { + my %coursehash = &coursedescription($cdom.'_'.$cnum); + my @possdoms = ($cdom); + if ($coursehash{'checkforpriv'}) { + push(@possdoms,split(/,/,$coursehash{'checkforpriv'})); + } + if (&privileged($uname,$udom,\@possdoms)) { $skipuser = 1; - my %coursehash = &coursedescription($cdom.'_'.$cnum); if ($coursehash{'nothideprivileged'}) { foreach my $item (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { my $user; @@ -3201,7 +3243,7 @@ sub userfileupload { } else { my $docuname=$env{'user.name'}; my $docudom=$env{'user.domain'}; - if (exists($env{'form.group'})) { + if ((exists($env{'form.group'})) || ($context eq 'syllabus')) { $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; } @@ -3351,7 +3393,9 @@ sub extract_embedded_items { &add_filetype($allfiles,$attr->{'src'},'src'); } if (lc($tagname) eq 'a') { - &add_filetype($allfiles,$attr->{'href'},'href'); + unless (($attr->{'href'} =~ /^#/) || ($attr->{'href'} eq '')) { + &add_filetype($allfiles,$attr->{'href'},'href'); + } } if (lc($tagname) eq 'script') { my $src; @@ -3882,6 +3926,10 @@ sub get_course_adv_roles { $nothide{$user}=1; } } + my @possdoms = ($coursehash{'domain'}); + if ($coursehash{'checkforpriv'}) { + push(@possdoms,split(/,/,$coursehash{'checkforpriv'})); + } my %returnhash=(); my %dumphash= &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); @@ -3894,20 +3942,7 @@ sub get_course_adv_roles { if (($tstart) && ($now<$tstart)) { next; } my ($role,$username,$domain,$section)=split(/\:/,$entry); if ($username eq '' || $domain eq '') { next; } - unless (ref($privileged{$domain}) eq 'HASH') { - my %dompersonnel = - &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now); - $privileged{$domain} = {}; - foreach my $server (keys(%dompersonnel)) { - if (ref($dompersonnel{$server}) eq 'HASH') { - foreach my $user (keys(%{$dompersonnel{$server}})) { - my ($trole,$uname,$udom) = split(/:/,$user); - $privileged{$udom}{$uname} = 1; - } - } - } - } - if ((exists($privileged{$domain}{$username})) && + if ((&privileged($username,$domain,\@possdoms)) && (!$nothide{$username.':'.$domain})) { next; } if ($role eq 'cr') { next; } if ($codes) { @@ -3938,8 +3973,7 @@ sub get_my_roles { if ($context eq 'userroles') { %dumphash = &dump('roles',$udom,$uname); } else { - %dumphash= - &dump('nohist_userroles',$udom,$uname); + %dumphash = &dump('nohist_userroles',$udom,$uname); if ($hidepriv) { my %coursehash=&coursedescription($udom.'_'.$uname); foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { @@ -4007,28 +4041,15 @@ sub get_my_roles { } } if ($hidepriv) { + my @privroles = ('dc','su'); if ($context eq 'userroles') { - if ((&privileged($username,$domain)) && - (!$nothide{$username.':'.$domain})) { - next; - } + next if (grep(/^\Q$role\E$/,@privroles)); } else { - unless (ref($privileged{$domain}) eq 'HASH') { - my %dompersonnel = - &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now); - $privileged{$domain} = {}; - if (keys(%dompersonnel)) { - foreach my $server (keys(%dompersonnel)) { - if (ref($dompersonnel{$server}) eq 'HASH') { - foreach my $user (keys(%{$dompersonnel{$server}})) { - my ($trole,$uname,$udom) = split(/:/,$user); - $privileged{$udom}{$uname} = $trole; - } - } - } - } + my $possdoms = [$domain]; + if (ref($roledoms) eq 'ARRAY') { + push(@{$possdoms},@{$roledoms}); } - if (exists($privileged{$domain}{$username})) { + if (&privileged($username,$domain,$possdoms,\@privroles)) { if (!$nothide{$username.':'.$domain}) { next; } @@ -4132,18 +4153,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 } ¤t_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); @@ -4249,7 +4284,7 @@ sub get_domain_roles { } my $rolelist; if (ref($roles) eq 'ARRAY') { - $rolelist = join(':',@{$roles}); + $rolelist = join('&',@{$roles}); } my %personnel = (); @@ -4791,9 +4826,12 @@ sub restore { if ($stuname) { $home=&homeserver($stuname,$domain); } if (!$symb) { - unless ($symb=escape(&symbread())) { return ''; } + return if ($namespace eq 'courserequests'); + unless ($symb=escape(&symbread())) { return ''; } } else { - $symb=&escape(&symbclean($symb)); + unless ($namespace eq 'courserequests') { + $symb=&escape(&symbclean($symb)); + } } if (!$namespace) { unless ($namespace=$env{'request.course.id'}) { @@ -4928,22 +4966,95 @@ sub update_released_required { # -------------------------------------------------See if a user is privileged sub privileged { - my ($username,$domain)=@_; - - my %rolesdump = &dump("roles", $domain, $username) or return 0; + my ($username,$domain,$possdomains,$possroles)=@_; my $now = time; + my $roles; + if (ref($possroles) eq 'ARRAY') { + $roles = $possroles; + } else { + $roles = ['dc','su']; + } + if (ref($possdomains) eq 'ARRAY') { + my %privileged = &privileged_by_domain($possdomains,$roles); + foreach my $dom (@{$possdomains}) { + if (($username =~ /^$match_username$/) && ($domain =~ /^$match_domain$/) && + (ref($privileged{$dom}) eq 'HASH')) { + foreach my $role (@{$roles}) { + if (ref($privileged{$dom}{$role}) eq 'HASH') { + if (exists($privileged{$dom}{$role}{$username.':'.$domain})) { + my ($end,$start) = split(/:/,$privileged{$dom}{$role}{$username.':'.$domain}); + return 1 unless (($end && $end < $now) || + ($start && $start > $now)); + } + } + } + } + } + } else { + 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 (($trole eq 'dc') || ($trole eq 'su')) { - return 1 unless ($tend && $tend < $now) - or ($tstart && $tstart > $now); + if (grep(/^\Q$trole\E$/,@{$roles})) { + return 1 unless ($tend && $tend < $now) + or ($tstart && $tstart > $now); } - } - + } + } return 0; } +sub privileged_by_domain { + my ($domains,$roles) = @_; + my %privileged = (); + my $cachetime = 60*60*24; + my $now = time; + unless ((ref($domains) eq 'ARRAY') && (ref($roles) eq 'ARRAY')) { + return %privileged; + } + foreach my $dom (@{$domains}) { + next if (ref($privileged{$dom}) eq 'HASH'); + my $needroles; + foreach my $role (@{$roles}) { + my ($result,$cached)=&is_cached_new('priv_'.$role,$dom); + if (defined($cached)) { + if (ref($result) eq 'HASH') { + $privileged{$dom}{$role} = $result; + } + } else { + $needroles = 1; + } + } + if ($needroles) { + my %dompersonnel = &get_domain_roles($dom,$roles); + $privileged{$dom} = {}; + foreach my $server (keys(%dompersonnel)) { + if (ref($dompersonnel{$server}) eq 'HASH') { + foreach my $item (keys(%{$dompersonnel{$server}})) { + 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} = + $dompersonnel{$server}{$item}; + } + } + } + if (ref($privileged{$dom}) eq 'HASH') { + foreach my $role (@{$roles}) { + if (ref($privileged{$dom}{$role}) eq 'HASH') { + &do_cache_new('priv_'.$role,$dom,$privileged{$dom}{$role},$cachetime); + } else { + my %hash = (); + &do_cache_new('priv_'.$role,$dom,\%hash,$cachetime); + } + } + } + } + } + return %privileged; +} + # -------------------------------------------------------- Get user privileges sub rolesinit { @@ -5389,12 +5500,36 @@ 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} = &thaw_unescape($value); + } + 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 } ¤t_machine_ids()) { + # user is hosted on this machine + $reply = LONCAPA::Lond::dump_with_regexp(join(':', ($udomain, + $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'}); + return %{&unserialize($reply, $escapedkeys)}; + } if ($regexp) { $regexp=&escape($regexp); } else { @@ -5406,7 +5541,7 @@ sub dump { if (!($rep =~ /^error/ )) { foreach my $item (@pairs) { my ($key,$value)=split(/=/,$item,2); - $key = &unescape($key); + $key = &unescape($key) unless ($escapedkeys); next if ($key =~ /^error: 2 /); $returnhash{$key}=&thaw_unescape($value); } @@ -5419,23 +5554,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 @@ -8366,7 +8487,8 @@ sub modifystudent { } 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,$credits) = @_; my ($cdom,$cnum,$chome); if (!$cid) { unless ($cid=$env{'request.course.id'}) { @@ -8642,7 +8764,7 @@ sub is_course { my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef, '.'); - return unless exists($courses{$cdom.'_'.$cnum}); + return unless(exists($courses{$cdom.'_'.$cnum})); return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum; } @@ -8667,6 +8789,9 @@ sub store_userdata { $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; } $namevalue=~s/\&$//; + unless ($namespace eq 'courserequests') { + $datakey = &escape($datakey); + } $result = &reply("store:$udom:$uname:$namespace:$datakey:". $namevalue,$uhome); } @@ -9517,7 +9642,7 @@ sub EXT_cache_set { # --------------------------------------------------------- Value of a Variable sub EXT { - my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_; + my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_; unless ($varname) { return ''; } #get real user name/domain, courseid and symb my $courseid; @@ -9632,26 +9757,51 @@ sub EXT { if (!$symbparm) { $symbparm=&symbread(); } } - if ($space eq 'title') { - if (!$symbparm) { $symbparm = $env{'request.filename'}; } - return &gettitle($symbparm); - } + if ($qualifier eq '') { + if ($space eq 'title') { + if (!$symbparm) { $symbparm = $env{'request.filename'}; } + return &gettitle($symbparm); + } - if ($space eq 'map') { - my ($map) = &decode_symb($symbparm); - return &symbread($map); - } - if ($space eq 'filename') { - if ($symbparm) { - return &clutter((&decode_symb($symbparm))[2]); + if ($space eq 'map') { + my ($map) = &decode_symb($symbparm); + return &symbread($map); + } + if ($space eq 'maptitle') { + my ($map) = &decode_symb($symbparm); + return &gettitle($map); + } + if ($space eq 'filename') { + if ($symbparm) { + return &clutter((&decode_symb($symbparm))[2]); + } + return &hreflocation('',$env{'request.filename'}); } - return &hreflocation('',$env{'request.filename'}); - } + + if ((defined($courseid)) && ($courseid eq $env{'request.course.id'}) && $symbparm) { + if ($space eq 'visibleparts') { + my $navmap = Apache::lonnavmaps::navmap->new(); + my $item; + if (ref($navmap)) { + my $res = $navmap->getBySymb($symbparm); + my $parts = $res->parts(); + if (ref($parts) eq 'ARRAY') { + $item = join(',',@{$parts}); + } + undef($navmap); + } + return $item; + } + } + } my ($section, $group, @groups); my ($courselevelm,$courselevel); - if ($symbparm && defined($courseid) && - $courseid eq $env{'request.course.id'}) { + if (($courseid eq '') && ($cid)) { + $courseid = $cid; + } + if (($symbparm && $courseid) && + (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid))) { #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; @@ -10276,78 +10426,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) { @@ -10401,7 +10479,7 @@ sub get_course_slots { my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum); my ($tmp) = keys(%slots); if ($tmp !~ /^(con_lost|error|no_such_host)/i) { - &Apache::lonnet::do_cache_new('allslots',$hashid,\%slots,600); + &do_cache_new('allslots',$hashid,\%slots,600); return %slots; } } @@ -11559,7 +11637,7 @@ sub get_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); + &do_cache_new('dns',$url,\@content,30*24*60*60); } &$func(\@content,$hashref); return; @@ -11934,9 +12012,9 @@ sub fetch_dns_checksums { } push(@{$iphost{$ip}},@{$name_to_host{$name}}); } - &Apache::lonnet::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; } @@ -11992,7 +12070,7 @@ sub fetch_dns_checksums { } $seen{$prim_ip} = 1; } - return &Apache::lonnet::do_cache_new('internetnames',$lonid,\@idns,12*60*60); + return &do_cache_new('internetnames',$lonid,\@idns,12*60*60); } } @@ -12001,6 +12079,39 @@ 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); } +# ------------------------------------------------------- Read loncaparev table +{ + sub load_loncaparevs { + if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") { + if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) { + while (my $configline=<$config>) { + chomp($configline); + my ($hostid,$loncaparev)=split(/:/,$configline); + $loncaparevs{$hostid}=$loncaparev; + } + close($config); + } + } + } +} + +# ----------------------------------------------------- Read serverhostID table +{ + sub load_serverhomeIDs { + if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") { + if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) { + while (my $configline=<$config>) { + chomp($configline); + my ($name,$id)=split(/:/,$configline); + $serverhomeIDs{$name}=$id; + } + close($config); + } + } + } +} + + BEGIN { # ----------------------------------- Read loncapa.conf and loncapa_apache.conf @@ -12076,34 +12187,15 @@ BEGIN { close($config); } -# ---------------------------------------------------------- Read loncaparev table -{ - if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") { - if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) { - while (my $configline=<$config>) { - chomp($configline); - my ($hostid,$loncaparev)=split(/:/,$configline); - $loncaparevs{$hostid}=$loncaparev; - } - close($config); - } - } -} +# --------------------------------------------------------- Read loncaparev table -# ---------------------------------------------------------- Read serverhostID table -{ - if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") { - if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) { - while (my $configline=<$config>) { - chomp($configline); - my ($name,$id)=split(/:/,$configline); - $serverhomeIDs{$name}=$id; - } - close($config); - } - } -} +&load_loncaparevs(); + +# ------------------------------------------------------- Read serverhostID table + +&load_serverhomeIDs(); +# ---------------------------------------------------------- Read releaseslist XML { my $file = $Apache::lonnet::perlvar{'lonTabDir'}.'/releaseslist.xml'; if (-e $file) { @@ -12313,8 +12405,8 @@ were new keys. I.E. 1:foo will become 1: Calling convention: - my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home); - &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home); + my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname); + &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname); For more detailed information, see lonnet specific documentation. @@ -12491,7 +12583,7 @@ environment). If no custom name is defi =item * -get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) : +get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv) : All arguments are optional. Returns a hash of a roles, either for co-author/assistant author roles for a user's Construction Space (default), or if $context is 'userroles', roles for the user himself, @@ -12514,7 +12606,31 @@ Additional optional arguments are: $type 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. +have active Domain Coordinator role in course's domain or in additional +domains (specified in 'Domains to check for privileged users' in course +environment -- set via: Course Settings -> Classlists and staff listing). + +=item * + +privileged($username,$domain,$possdomains,$possroles) : returns 1 if user +$username:$domain is a privileged user (e.g., Domain Coordinator or Super User) +$possdomains and $possroles are optional array refs -- to domains to check and +roles to check. If $possdomains is not specified, a dump will be done of the +users' roles.db to check for a dc or su role in any domain. This can be +time consuming if &privileged is called repeatedly (e.g., when displaying a +classlist), so in such cases, supplying a $possdomains array is preferred, as +this then allows &privileged_by_domain() to be used, which caches the identity +of privileged users, eliminating the need for repeated calls to &dump(). + +=item * + +privileged_by_domain($possdomains,$roles) : returns a hash of a hash of a hash, +where the outer hash keys are domains specified in the $possdomains array ref, +next inner hash keys are privileged roles specified in the $roles array ref, +and the innermost hash contains key = value pairs for username:domain = end:start +for active or future "privileged" users with that role in that domain. To avoid +repeated dumps of domain roles -- via &get_domain_roles() -- contents of the +innerhash are cached using priv_$role and $dom as the identifiers. =back @@ -12781,10 +12897,15 @@ resource. Expects the local filesystem p =item * -EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of -a vairety of different possible values, $varname should be a request -string, and the other parameters can be used to specify who and what -one is asking about. +EXT($varname,$symb,$udom,$uname,$usection,$recurse,$cid) : evaluates +and returns the value of a variety of different possible values, +$varname should be a request string, and the other parameters can be +used to specify who and what one is asking about. Ordinarily, $cid +does not need to be specified, as it is retrived from +$env{'request.course.id'}, but &Apache::lonnet::EXT() is called +within lonuserstate::loadmap() when initializing a course, before +$env{'request.course.id'} has been set, so it needs to be provided +in that one case. Possible values for $varname are environment.lastname (or other item from the envirnment hash), user.name (or someother aspect about the