version 1.1172.2.19, 2013/03/02 15:34:17
|
version 1.1172.2.28, 2013/06/27 18:34:21
|
Line 97 use File::MMagic;
|
Line 97 use File::MMagic;
|
use LONCAPA qw(:DEFAULT :match); |
use LONCAPA qw(:DEFAULT :match); |
use LONCAPA::Configuration; |
use LONCAPA::Configuration; |
use LONCAPA::lonmetadata; |
use LONCAPA::lonmetadata; |
|
use LONCAPA::Lond; |
|
|
use File::Copy; |
use File::Copy; |
|
|
Line 2017 sub get_domain_defaults {
|
Line 2018 sub get_domain_defaults {
|
$domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'}; |
$domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'}; |
} |
} |
} |
} |
&Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, |
&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime); |
$cachetime); |
|
return %domdefaults; |
return %domdefaults; |
} |
} |
|
|
Line 2849 sub in_course {
|
Line 2849 sub in_course {
|
my ($udom,$uname,$cdom,$cnum,$type,$hideprivileged) = @_; |
my ($udom,$uname,$cdom,$cnum,$type,$hideprivileged) = @_; |
if ($hideprivileged) { |
if ($hideprivileged) { |
my $skipuser; |
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; |
$skipuser = 1; |
my %coursehash = &coursedescription($cdom.'_'.$cnum); |
|
if ($coursehash{'nothideprivileged'}) { |
if ($coursehash{'nothideprivileged'}) { |
foreach my $item (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { |
foreach my $item (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { |
my $user; |
my $user; |
Line 3184 sub userfileupload {
|
Line 3188 sub userfileupload {
|
$codebase,$thumbwidth,$thumbheight, |
$codebase,$thumbwidth,$thumbheight, |
$resizewidth,$resizeheight,$context,$mimetype); |
$resizewidth,$resizeheight,$context,$mimetype); |
} else { |
} else { |
$fname=$env{'form.folder'}.'/'.$fname; |
if ($env{'form.folder'}) { |
|
$fname=$env{'form.folder'}.'/'.$fname; |
|
} |
return &process_coursefile('uploaddoc',$docuname,$docudom, |
return &process_coursefile('uploaddoc',$docuname,$docudom, |
$fname,$formname,$parser, |
$fname,$formname,$parser, |
$allfiles,$codebase,$mimetype); |
$allfiles,$codebase,$mimetype); |
Line 3199 sub userfileupload {
|
Line 3205 sub userfileupload {
|
} else { |
} else { |
my $docuname=$env{'user.name'}; |
my $docuname=$env{'user.name'}; |
my $docudom=$env{'user.domain'}; |
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'}; |
$docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; |
$docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; |
$docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; |
} |
} |
Line 3349 sub extract_embedded_items {
|
Line 3355 sub extract_embedded_items {
|
&add_filetype($allfiles,$attr->{'src'},'src'); |
&add_filetype($allfiles,$attr->{'src'},'src'); |
} |
} |
if (lc($tagname) eq 'a') { |
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') { |
if (lc($tagname) eq 'script') { |
my $src; |
my $src; |
Line 3880 sub get_course_adv_roles {
|
Line 3888 sub get_course_adv_roles {
|
$nothide{$user}=1; |
$nothide{$user}=1; |
} |
} |
} |
} |
|
my @possdoms = ($coursehash{'domain'}); |
|
if ($coursehash{'checkforpriv'}) { |
|
push(@possdoms,split(/,/,$coursehash{'checkforpriv'})); |
|
} |
my %returnhash=(); |
my %returnhash=(); |
my %dumphash= |
my %dumphash= |
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); |
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); |
Line 3892 sub get_course_adv_roles {
|
Line 3904 sub get_course_adv_roles {
|
if (($tstart) && ($now<$tstart)) { next; } |
if (($tstart) && ($now<$tstart)) { next; } |
my ($role,$username,$domain,$section)=split(/\:/,$entry); |
my ($role,$username,$domain,$section)=split(/\:/,$entry); |
if ($username eq '' || $domain eq '') { next; } |
if ($username eq '' || $domain eq '') { next; } |
unless (ref($privileged{$domain}) eq 'HASH') { |
if ((&privileged($username,$domain,\@possdoms)) && |
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})) && |
|
(!$nothide{$username.':'.$domain})) { next; } |
(!$nothide{$username.':'.$domain})) { next; } |
if ($role eq 'cr') { next; } |
if ($role eq 'cr') { next; } |
if ($codes) { |
if ($codes) { |
Line 3936 sub get_my_roles {
|
Line 3935 sub get_my_roles {
|
if ($context eq 'userroles') { |
if ($context eq 'userroles') { |
%dumphash = &dump('roles',$udom,$uname); |
%dumphash = &dump('roles',$udom,$uname); |
} else { |
} else { |
%dumphash= |
%dumphash = &dump('nohist_userroles',$udom,$uname); |
&dump('nohist_userroles',$udom,$uname); |
|
if ($hidepriv) { |
if ($hidepriv) { |
my %coursehash=&coursedescription($udom.'_'.$uname); |
my %coursehash=&coursedescription($udom.'_'.$uname); |
foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { |
foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { |
Line 4005 sub get_my_roles {
|
Line 4003 sub get_my_roles {
|
} |
} |
} |
} |
if ($hidepriv) { |
if ($hidepriv) { |
|
my @privroles = ('dc','su'); |
if ($context eq 'userroles') { |
if ($context eq 'userroles') { |
if ((&privileged($username,$domain)) && |
next if (grep(/^\Q$role\E$/,@privroles)); |
(!$nothide{$username.':'.$domain})) { |
|
next; |
|
} |
|
} else { |
} else { |
unless (ref($privileged{$domain}) eq 'HASH') { |
my $possdoms = [$domain]; |
my %dompersonnel = |
if (ref($roledoms) eq 'ARRAY') { |
&Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now); |
push(@{$possdoms},@{$roledoms}); |
$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; |
|
} |
|
} |
|
} |
|
} |
|
} |
} |
if (exists($privileged{$domain}{$username})) { |
if (&privileged($username,$domain,$possdoms,\@privroles)) { |
if (!$nothide{$username.':'.$domain}) { |
if (!$nothide{$username.':'.$domain}) { |
next; |
next; |
} |
} |
Line 4130 sub courseiddump {
|
Line 4115 sub courseiddump {
|
|
|
if (($domfilter eq '') || |
if (($domfilter eq '') || |
(&host_domain($tryserver) eq $domfilter)) { |
(&host_domain($tryserver) eq $domfilter)) { |
my $rep = |
my $rep; |
&reply('courseiddump:'.&host_domain($tryserver).':'. |
if (grep { $_ eq $tryserver } ¤t_machine_ids()) { |
$sincefilter.':'.&escape($descfilter).':'. |
$rep = &LONCAPA::Lond::dump_course_id_handler( |
&escape($instcodefilter).':'.&escape($ownerfilter). |
join(":", (&host_domain($tryserver), $sincefilter, |
':'.&escape($coursefilter).':'.&escape($typefilter). |
&escape($descfilter), &escape($instcodefilter), |
':'.&escape($regexp_ok).':'.$as_hash.':'. |
&escape($ownerfilter), &escape($coursefilter), |
&escape($selfenrollonly).':'.&escape($catfilter).':'. |
&escape($typefilter), &escape($regexp_ok), |
$showhidden.':'.$caller.':'.&escape($cloner).':'. |
$as_hash, &escape($selfenrollonly), |
&escape($cc_clone).':'.$cloneonly.':'. |
&escape($catfilter), $showhidden, $caller, |
&escape($createdbefore).':'.&escape($createdafter).':'. |
&escape($cloner), &escape($cc_clone), $cloneonly, |
&escape($creationcontext).':'.$domcloner, |
&escape($createdbefore), &escape($createdafter), |
$tryserver); |
&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); |
my @pairs=split(/\&/,$rep); |
foreach my $item (@pairs) { |
foreach my $item (@pairs) { |
my ($key,$value)=split(/\=/,$item,2); |
my ($key,$value)=split(/\=/,$item,2); |
Line 4247 sub get_domain_roles {
|
Line 4246 sub get_domain_roles {
|
} |
} |
my $rolelist; |
my $rolelist; |
if (ref($roles) eq 'ARRAY') { |
if (ref($roles) eq 'ARRAY') { |
$rolelist = join(':',@{$roles}); |
$rolelist = join('&',@{$roles}); |
} |
} |
my %personnel = (); |
my %personnel = (); |
|
|
Line 4789 sub restore {
|
Line 4788 sub restore {
|
if ($stuname) { $home=&homeserver($stuname,$domain); } |
if ($stuname) { $home=&homeserver($stuname,$domain); } |
|
|
if (!$symb) { |
if (!$symb) { |
unless ($symb=escape(&symbread())) { return ''; } |
return if ($namespace eq 'courserequests'); |
|
unless ($symb=escape(&symbread())) { return ''; } |
} else { |
} else { |
$symb=&escape(&symbclean($symb)); |
unless ($namespace eq 'courserequests') { |
|
$symb=&escape(&symbclean($symb)); |
|
} |
} |
} |
if (!$namespace) { |
if (!$namespace) { |
unless ($namespace=$env{'request.course.id'}) { |
unless ($namespace=$env{'request.course.id'}) { |
Line 4926 sub update_released_required {
|
Line 4928 sub update_released_required {
|
# -------------------------------------------------See if a user is privileged |
# -------------------------------------------------See if a user is privileged |
|
|
sub privileged { |
sub privileged { |
my ($username,$domain)=@_; |
my ($username,$domain,$possdomains,$possroles)=@_; |
|
|
my %rolesdump = &dump("roles", $domain, $username) or return 0; |
|
my $now = time; |
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); |
my ($trole, $tend, $tstart) = split(/_/, $role); |
if (($trole eq 'dc') || ($trole eq 'su')) { |
if (grep(/^\Q$trole\E$/,@{$roles})) { |
return 1 unless ($tend && $tend < $now) |
return 1 unless ($tend && $tend < $now) |
or ($tstart && $tstart > $now); |
or ($tstart && $tstart > $now); |
} |
} |
} |
} |
|
} |
return 0; |
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 |
# -------------------------------------------------------- Get user privileges |
|
|
sub rolesinit { |
sub rolesinit { |
Line 5387 sub del {
|
Line 5462 sub del {
|
|
|
# -------------------------------------------------------------- dump interface |
# -------------------------------------------------------------- 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 { |
sub dump { |
my ($namespace,$udomain,$uname,$regexp,$range)=@_; |
my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_; |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
my $uhome=&homeserver($uname,$udomain); |
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) { |
if ($regexp) { |
$regexp=&escape($regexp); |
$regexp=&escape($regexp); |
} else { |
} else { |
Line 5404 sub dump {
|
Line 5503 sub dump {
|
if (!($rep =~ /^error/ )) { |
if (!($rep =~ /^error/ )) { |
foreach my $item (@pairs) { |
foreach my $item (@pairs) { |
my ($key,$value)=split(/=/,$item,2); |
my ($key,$value)=split(/=/,$item,2); |
$key = &unescape($key); |
$key = &unescape($key) unless ($escapedkeys); |
next if ($key =~ /^error: 2 /); |
next if ($key =~ /^error: 2 /); |
$returnhash{$key}=&thaw_unescape($value); |
$returnhash{$key}=&thaw_unescape($value); |
} |
} |
Line 5417 sub dump {
|
Line 5516 sub dump {
|
|
|
sub dumpstore { |
sub dumpstore { |
my ($namespace,$udomain,$uname,$regexp,$range)=@_; |
my ($namespace,$udomain,$uname,$regexp,$range)=@_; |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
# same as dump but keys must be escaped. They may contain colon separated |
if (!$uname) { $uname=$env{'user.name'}; } |
# lists of values that may themself contain colons (e.g. symbs). |
my $uhome=&homeserver($uname,$udomain); |
return &dump($namespace, $udomain, $uname, $regexp, $range, 1); |
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; |
|
} |
} |
|
|
# -------------------------------------------------------------- keys interface |
# -------------------------------------------------------------- keys interface |
Line 8364 sub modifystudent {
|
Line 8449 sub modifystudent {
|
} |
} |
|
|
sub modify_student_enrollment { |
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); |
my ($cdom,$cnum,$chome); |
if (!$cid) { |
if (!$cid) { |
unless ($cid=$env{'request.course.id'}) { |
unless ($cid=$env{'request.course.id'}) { |
Line 8640 sub is_course {
|
Line 8726 sub is_course {
|
my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef, |
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; |
return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum; |
} |
} |
|
|
Line 8665 sub store_userdata {
|
Line 8751 sub store_userdata {
|
$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; |
$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; |
} |
} |
$namevalue=~s/\&$//; |
$namevalue=~s/\&$//; |
|
unless ($namespace eq 'courserequests') { |
|
$datakey = &escape($datakey); |
|
} |
$result = &reply("store:$udom:$uname:$namespace:$datakey:". |
$result = &reply("store:$udom:$uname:$namespace:$datakey:". |
$namevalue,$uhome); |
$namevalue,$uhome); |
} |
} |
Line 9515 sub EXT_cache_set {
|
Line 9604 sub EXT_cache_set {
|
# --------------------------------------------------------- Value of a Variable |
# --------------------------------------------------------- Value of a Variable |
sub EXT { |
sub EXT { |
|
|
my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_; |
my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_; |
unless ($varname) { return ''; } |
unless ($varname) { return ''; } |
#get real user name/domain, courseid and symb |
#get real user name/domain, courseid and symb |
my $courseid; |
my $courseid; |
Line 9648 sub EXT {
|
Line 9737 sub EXT {
|
|
|
my ($section, $group, @groups); |
my ($section, $group, @groups); |
my ($courselevelm,$courselevel); |
my ($courselevelm,$courselevel); |
if ($symbparm && defined($courseid) && |
if (($courseid eq '') && ($cid)) { |
$courseid eq $env{'request.course.id'}) { |
$courseid = $cid; |
|
} |
|
if (($symbparm && $courseid) && |
|
(($courseid eq $env{'request.course.id'}) || ($courseid eq $cid))) { |
|
|
#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest; |
#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest; |
|
|
Line 9896 sub metadata {
|
Line 9988 sub metadata {
|
# if it is a non metadata possible uri return quickly |
# if it is a non metadata possible uri return quickly |
if (($uri eq '') || |
if (($uri eq '') || |
(($uri =~ m|^/*adm/|) && |
(($uri =~ m|^/*adm/|) && |
($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) || |
($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard)$})) || |
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { |
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { |
return undef; |
return undef; |
} |
} |
Line 10274 sub gettitle {
|
Line 10366 sub gettitle {
|
return $title; |
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 { |
sub get_slot { |
my ($which,$cnum,$cdom)=@_; |
my ($which,$cnum,$cdom)=@_; |
if (!$cnum || !$cdom) { |
if (!$cnum || !$cdom) { |
Line 10399 sub get_course_slots {
|
Line 10419 sub get_course_slots {
|
my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum); |
my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum); |
my ($tmp) = keys(%slots); |
my ($tmp) = keys(%slots); |
if ($tmp !~ /^(con_lost|error|no_such_host)/i) { |
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; |
return %slots; |
} |
} |
} |
} |
Line 11557 sub get_dns {
|
Line 11577 sub get_dns {
|
next if ($response->is_error()); |
next if ($response->is_error()); |
my @content = split("\n",$response->content); |
my @content = split("\n",$response->content); |
unless ($nocache) { |
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); |
&$func(\@content,$hashref); |
return; |
return; |
Line 11932 sub fetch_dns_checksums {
|
Line 11952 sub fetch_dns_checksums {
|
} |
} |
push(@{$iphost{$ip}},@{$name_to_host{$name}}); |
push(@{$iphost{$ip}},@{$name_to_host{$name}}); |
} |
} |
&Apache::lonnet::do_cache_new('iphost','iphost', |
&do_cache_new('iphost','iphost', |
[\%iphost,\%name_to_ip,\%lonid_to_ip], |
[\%iphost,\%name_to_ip,\%lonid_to_ip], |
48*60*60); |
48*60*60); |
|
|
return %iphost; |
return %iphost; |
} |
} |
Line 11990 sub fetch_dns_checksums {
|
Line 12010 sub fetch_dns_checksums {
|
} |
} |
$seen{$prim_ip} = 1; |
$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); |
} |
} |
|
|
} |
} |
Line 11999 sub all_loncaparevs {
|
Line 12019 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); |
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 { |
BEGIN { |
|
|
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
Line 12074 BEGIN {
|
Line 12127 BEGIN {
|
close($config); |
close($config); |
} |
} |
|
|
# ---------------------------------------------------------- Read loncaparev table |
# --------------------------------------------------------- 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 serverhostID table |
&load_loncaparevs(); |
{ |
|
if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") { |
# ------------------------------------------------------- Read serverhostID table |
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_serverhomeIDs(); |
|
|
|
# ---------------------------------------------------------- Read releaseslist XML |
{ |
{ |
my $file = $Apache::lonnet::perlvar{'lonTabDir'}.'/releaseslist.xml'; |
my $file = $Apache::lonnet::perlvar{'lonTabDir'}.'/releaseslist.xml'; |
if (-e $file) { |
if (-e $file) { |
Line 12311 were new keys. I.E. 1:foo will become 1:
|
Line 12345 were new keys. I.E. 1:foo will become 1:
|
|
|
Calling convention: |
Calling convention: |
|
|
my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home); |
my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname); |
&Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home); |
&Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname); |
|
|
For more detailed information, see lonnet specific documentation. |
For more detailed information, see lonnet specific documentation. |
|
|
Line 12489 environment). If no custom name is defi
|
Line 12523 environment). If no custom name is defi
|
|
|
=item * |
=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 |
All arguments are optional. Returns a hash of a roles, either for |
co-author/assistant author roles for a user's Construction Space |
co-author/assistant author roles for a user's Construction Space |
(default), or if $context is 'userroles', roles for the user himself, |
(default), or if $context is 'userroles', roles for the user himself, |
Line 12512 Additional optional arguments are: $type
|
Line 12546 Additional optional arguments are: $type
|
to certain user status types -- previous (expired roles), active (currently |
to certain user status types -- previous (expired roles), active (currently |
available roles) or future (roles available in the future), and |
available roles) or future (roles available in the future), and |
$hideprivileged -- if true will not report course roles for users who |
$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 |
=back |
|
|
Line 12779 resource. Expects the local filesystem p
|
Line 12837 resource. Expects the local filesystem p
|
|
|
=item * |
=item * |
|
|
EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of |
EXT($varname,$symb,$udom,$uname,$usection,$recurse,$cid) : evaluates |
a vairety of different possible values, $varname should be a request |
and returns the value of a variety of different possible values, |
string, and the other parameters can be used to specify who and what |
$varname should be a request string, and the other parameters can be |
one is asking about. |
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 |
Possible values for $varname are environment.lastname (or other item |
from the envirnment hash), user.name (or someother aspect about the |
from the envirnment hash), user.name (or someother aspect about the |