--- loncom/lonnet/perl/lonnet.pm 2013/02/02 00:22:47 1.1210 +++ loncom/lonnet/perl/lonnet.pm 2013/05/21 18:57:45 1.1223 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1210 2013/02/02 00:22:47 raeburn Exp $ +# $Id: lonnet.pm,v 1.1223 2013/05/21 18:57:45 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -78,7 +78,7 @@ use Image::Magick; use Encode; -use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir +use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $apache $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease %managerstab); @@ -634,6 +634,13 @@ 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; } @@ -2003,6 +2010,10 @@ sub get_domain_defaults { foreach my $item ('canuse_pdfforms') { $domdefaults{$item} = $domconfig{'coursedefaults'}{$item}; } + if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') { + $domdefaults{'officialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'official'}; + $domdefaults{'unofficialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'unofficial'}; + } } if (ref($domconfig{'usersessions'}) eq 'HASH') { if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') { @@ -2012,8 +2023,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; } @@ -2847,9 +2857,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; @@ -3182,7 +3196,9 @@ sub userfileupload { $codebase,$thumbwidth,$thumbheight, $resizewidth,$resizeheight,$context,$mimetype); } else { - $fname=$env{'form.folder'}.'/'.$fname; + if ($env{'form.folder'}) { + $fname=$env{'form.folder'}.'/'.$fname; + } return &process_coursefile('uploaddoc',$docuname,$docudom, $fname,$formname,$parser, $allfiles,$codebase,$mimetype); @@ -3197,7 +3213,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'}; } @@ -3347,7 +3363,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; @@ -3878,6 +3896,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'}); @@ -3890,20 +3912,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) { @@ -3934,8 +3943,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'})) { @@ -4003,28 +4011,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; } @@ -4259,7 +4254,7 @@ sub get_domain_roles { } my $rolelist; if (ref($roles) eq 'ARRAY') { - $rolelist = join(':',@{$roles}); + $rolelist = join('&',@{$roles}); } my %personnel = (); @@ -4938,22 +4933,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')) { + if (grep(/^\Q$trole\E$/,@{$roles})) { return 1 unless ($tend && $tend < $now) - or ($tstart && $tstart > $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 { @@ -5063,9 +5131,11 @@ sub rolesinit { } sub set_arearole { - my ($trole,$area,$tstart,$tend,$domain,$username) = @_; + my ($trole,$area,$tstart,$tend,$domain,$username,$nolog) = @_; + unless ($nolog) { # 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); } @@ -5334,7 +5404,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'}); + $env{'user.name'},1); my %ccrole = (); &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area); my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole); @@ -7432,8 +7502,8 @@ sub auto_validate_instcode { } $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'. &escape($instcode).':'.&escape($owner),$homeserver)); - my ($outcome,$description) = map { &unescape($_); } split('&',$response,2); - return ($outcome,$description); + my ($outcome,$description,$defaultcredits) = map { &unescape($_); } split('&',$response,3); + return ($outcome,$description,$defaultcredits); } sub auto_create_password { @@ -8373,7 +8443,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)=@_; + $selfenroll,$context,$inststatus,$credits)=@_; if (!$cid) { unless ($cid=$env{'request.course.id'}) { return 'not_in_class'; @@ -8388,12 +8458,14 @@ 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); + $gene,$usec,$end,$start,$type,$locktype, + $cid,$selfenroll,$context,$credits); return $reply; } sub modify_student_enrollment { - my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context) = @_; + 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'}) { @@ -8440,7 +8512,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) }, + join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits) }, $cdom,$cnum); if (($reply eq 'ok') || ($reply eq 'delayed')) { &devalidate_getsection_cache($udom,$uname,$cid); @@ -8669,7 +8741,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; } @@ -9925,7 +9997,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|/bulletinboard$|)) || + ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard)$})) || ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { return undef; } @@ -10303,78 +10375,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) { @@ -10428,7 +10428,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; } } @@ -11587,7 +11587,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; @@ -11602,7 +11602,7 @@ sub get_dns { } # ------------------------------------------------------Get DNS checksums file -sub write_dns_checksums_tab { +sub parse_dns_checksums_tab { my ($lines,$hashref) = @_; my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'}); my $loncaparev = &get_server_loncaparev($machine_dom); @@ -11648,8 +11648,8 @@ sub write_dns_checksums_tab { sub fetch_dns_checksums { my %checksums; - &get_dns('/adm/dns/checksums',\&write_dns_checksums_tab,1,1, - \%checksums); + &get_dns('/adm/dns/checksums',\&parse_dns_checksums_tab,1,1, + \%checksums); return \%checksums; } @@ -11962,9 +11962,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; } @@ -12020,7 +12020,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); } } @@ -12190,6 +12190,17 @@ $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; + } + } + } } @@ -12508,7 +12519,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, @@ -12531,7 +12542,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 @@ -12625,7 +12660,9 @@ 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<$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. =back @@ -12670,6 +12707,8 @@ Inputs: =item $context +=item $credits, number of credits student will earn from this class + =back