--- loncom/lonnet/perl/lonnet.pm 2009/02/10 11:15:16 1.986 +++ loncom/lonnet/perl/lonnet.pm 2009/07/20 23:33:11 1.1005 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.986 2009/02/10 11:15:16 foxr Exp $ +# $Id: lonnet.pm,v 1.1005 2009/07/20 23:33:11 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -74,9 +74,7 @@ use strict; use LWP::UserAgent(); use HTTP::Date; use Image::Magick; -use IO::Socket; -# use Date::Parse; use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $_64bit %env %protocol); @@ -198,6 +196,33 @@ sub get_server_timezone { } } +sub get_server_loncaparev { + my ($dom,$lonhost) = @_; + if (defined($lonhost)) { + if (!defined(&hostname($lonhost))) { + undef($lonhost); + } + } + if (!defined($lonhost)) { + if (defined(&domain($dom,'primary'))) { + $lonhost=&domain($dom,'primary'); + if ($lonhost eq 'no_host') { + undef($lonhost); + } + } + } + if (defined($lonhost)) { + my $cachetime = 24*3600; + my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost); + if (defined($cached)) { + return $loncaparev; + } else { + my $loncaparev = &reply('serverloncaparev',$lonhost); + return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime); + } + } +} + # -------------------------------------------------- Non-critical communication sub subreply { my ($cmd,$server)=@_; @@ -528,7 +553,7 @@ sub appenv { # ----------------------------------------------------- Delete from Environment sub delenv { - my $delthis=shift; + my ($delthis,$regexp) = @_; if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { &logthis("WARNING: ". "Attempt to delete from environment ".$delthis); @@ -541,10 +566,17 @@ sub delenv { tie(my %disk_env,'GDBM_File',$env{'user.environment'}, (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { foreach my $key (keys(%disk_env)) { - if ($key=~/^\Q$delthis\E/) { - delete($env{$key}); - delete($disk_env{$key}); - } + if ($regexp) { + if ($key=~/^$delthis/) { + delete($env{$key}); + delete($disk_env{$key}); + } + } else { + if ($key=~/^\Q$delthis\E/) { + delete($env{$key}); + delete($disk_env{$key}); + } + } } untie(%disk_env); } @@ -686,7 +718,12 @@ sub spareserver { if ($protocol{$spare_server} eq 'https') { $protocol = $protocol{$spare_server}; } - $spare_server = $protocol.'://'.&hostname($spare_server); + if (defined($spare_server)) { + my $hostname = &hostname($spare_server); + if (defined($hostname)) { + $spare_server = $protocol.'://'.$hostname; + } + } } return $spare_server; } @@ -998,27 +1035,34 @@ sub put_dom { sub retrieve_inst_usertypes { my ($udom) = @_; my (%returnhash,@order); - if (defined(&domain($udom,'primary'))) { - my $uhome=&domain($udom,'primary'); - my $rep=&reply("inst_usertypes:$udom",$uhome); - if ($rep =~ /^(con_lost|error|no_such_host|refused)/) { - &logthis("get_dom failed - $rep returned from $uhome in domain: $udom"); - return (\%returnhash,\@order); - } - my ($hashitems,$orderitems) = split(/:/,$rep); - my @pairs=split(/\&/,$hashitems); - foreach my $item (@pairs) { - my ($key,$value)=split(/=/,$item,2); - $key = &unescape($key); - next if ($key =~ /^error: 2 /); - $returnhash{$key}=&thaw_unescape($value); - } - my @esc_order = split(/\&/,$orderitems); - foreach my $item (@esc_order) { - push(@order,&unescape($item)); - } + my %domdefs = &Apache::lonnet::get_domain_defaults($udom); + if ((ref($domdefs{'inststatustypes'}) eq 'HASH') && + (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) { + %returnhash = %{$domdefs{'inststatustypes'}}; + @order = @{$domdefs{'inststatusorder'}}; } else { - &logthis("get_dom failed - no primary domain server for $udom"); + if (defined(&domain($udom,'primary'))) { + my $uhome=&domain($udom,'primary'); + my $rep=&reply("inst_usertypes:$udom",$uhome); + if ($rep =~ /^(con_lost|error|no_such_host|refused)/) { + &logthis("get_dom failed - $rep returned from $uhome in domain: $udom"); + return (\%returnhash,\@order); + } + my ($hashitems,$orderitems) = split(/:/,$rep); + my @pairs=split(/\&/,$hashitems); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + $returnhash{$key}=&thaw_unescape($value); + } + my @esc_order = split(/\&/,$orderitems); + foreach my $item (@esc_order) { + push(@order,&unescape($item)); + } + } else { + &logthis("get_dom failed - no primary domain server for $udom"); + } } return (\%returnhash,\@order); } @@ -1255,7 +1299,8 @@ sub get_domain_defaults { } my %domdefaults; my %domconfig = - &Apache::lonnet::get_dom('configuration',['defaults','quotas'],$domain); + &Apache::lonnet::get_dom('configuration',['defaults','quotas', + 'requestcourses','inststatus'],$domain); if (ref($domconfig{'defaults'}) eq 'HASH') { $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; @@ -1285,6 +1330,11 @@ sub get_domain_defaults { $domdefaults{$item} = $domconfig{'requestcourses'}{$item}; } } + if (ref($domconfig{'inststatus'}) eq 'HASH') { + foreach my $item ('inststatustypes','inststatusorder') { + $domdefaults{$item} = $domconfig{'inststatus'}{$item}; + } + } &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, $cachetime); return %domdefaults; @@ -1816,6 +1866,8 @@ sub ssi_body { if ($filelink=~/^https?\:/) { ($output,$response)=&externalssi($filelink); } else { + $filelink .= $filelink=~/\?/ ? '&' : '?'; + $filelink .= 'inhibitmenu=yes'; ($output,$response)=&ssi($filelink,%form); } $output=~s|//(\s*)?\s||gs; @@ -1859,7 +1911,7 @@ sub ssi { &Apache::lonenc::check_encrypt(\$fn); if (%form) { $request=new HTTP::Request('POST',&absolute_url().$fn); - $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); + $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form))); } else { $request=new HTTP::Request('GET',&absolute_url().$fn); } @@ -2121,9 +2173,12 @@ sub userfileupload { close($fh); return $fullpath.'/'.$fname; } - + if ($subdir eq 'scantron') { + $fname = 'scantron_orig_'.$fname; + } else { # Create the directory if not present - $fname="$subdir/$fname"; + $fname="$subdir/$fname"; + } if ($coursedoc) { my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; @@ -2506,7 +2561,7 @@ sub flushcourselogs { # Reverse lookup of domain roles (dc, ad, li, sc, au) # my %domrolebuffer = (); - foreach my $entry (keys %domainrolehash) { + foreach my $entry (keys(%domainrolehash)) { my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry); if ($domrolebuffer{$rudom}) { $domrolebuffer{$rudom}.='&'.&escape($entry). @@ -2661,6 +2716,9 @@ sub courserolelog { $storehash{'section'} = $sec; } &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom); + if (($trole ne 'st') || ($sec ne '')) { + &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum); + } } } return; @@ -2670,6 +2728,7 @@ sub get_course_adv_roles { my ($cid,$codes) = @_; $cid=$env{'request.course.id'} unless (defined($cid)); my %coursehash=&coursedescription($cid); + my $crstype = &Apache::loncommon::course_type($cid); my %nothide=(); foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { if ($user !~ /:/) { @@ -2682,15 +2741,29 @@ sub get_course_adv_roles { my %dumphash= &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); my $now=time; - foreach my $entry (keys %dumphash) { + my %privileged; + foreach my $entry (keys(%dumphash)) { my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); if (($tstart) && ($tstart<0)) { next; } if (($tend) && ($tend<$now)) { next; } if (($tstart) && ($now<$tstart)) { next; } my ($role,$username,$domain,$section)=split(/\:/,$entry); if ($username eq '' || $domain eq '') { next; } - if ((&privileged($username,$domain)) && - (!$nothide{$username.':'.$domain})) { 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})) && + (!$nothide{$username.':'.$domain})) { next; } if ($role eq 'cr') { next; } if ($codes) { if ($section) { $role .= ':'.$section; } @@ -2700,7 +2773,7 @@ sub get_course_adv_roles { $returnhash{$role}=$username.':'.$domain; } } else { - my $key=&plaintext($role); + my $key=&plaintext($role,$crstype); if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; } if ($returnhash{$key}) { $returnhash{$key}.=','.$username.':'.$domain; @@ -2735,6 +2808,7 @@ sub get_my_roles { } my %returnhash=(); my $now=time; + my %privileged; foreach my $entry (keys(%dumphash)) { my ($role,$tend,$tstart); if ($context eq 'userroles') { @@ -2783,9 +2857,32 @@ sub get_my_roles { } } if ($hidepriv) { - if ((&privileged($username,$domain)) && - (!$nothide{$username.':'.$domain})) { - next; + if ($context eq 'userroles') { + if ((&privileged($username,$domain)) && + (!$nothide{$username.':'.$domain})) { + next; + } + } 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; + } + } + } + } + } + if (exists($privileged{$domain}{$username})) { + if (!$nothide{$username.':'.$domain}) { + next; + } + } } } if ($withsec) { @@ -3355,7 +3452,7 @@ sub tmpreset { if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', &GDBM_WRCREAT(),0640)) { - foreach my $key (keys %hash) { + foreach my $key (keys(%hash)) { if ($key=~ /:$symb/) { delete($hash{$key}); } @@ -3791,7 +3888,7 @@ sub set_userprivs { my $adv=0; my %grouproles = (); if (keys(%{$allgroups}) > 0) { - foreach my $role (keys %{$allroles}) { + foreach my $role (keys(%{$allroles})) { my ($trole,$area,$sec,$extendedarea); if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) { $trole = $1; @@ -3834,6 +3931,101 @@ sub set_userprivs { return ($author,$adv); } +sub role_status { + my ($rolekey,$then,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_; + my @pwhere = (); + if (exists($env{$rolekey}) && $env{$rolekey} ne '') { + (undef,undef,$$role,@pwhere)=split(/\./,$rolekey); + unless (!defined($$role) || $$role eq '') { + $$where=join('.',@pwhere); + $$trolecode=$$role.'.'.$$where; + ($$tstart,$$tend)=split(/\./,$env{$rolekey}); + $$tstatus='is'; + if ($$tstart && $$tstart>$then) { + $$tstatus='future'; + if ($$tstart && $$tstart>$refresh) { + if ($$tstart<$now) { + if (($$where ne '') && ($$role ne '')) { + my (%allroles,%allgroups,$group_privs); + my %userroles = ( + 'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend + ); + my $spec=$$role.'.'.$$where; + my ($tdummy,$tdomain,$trest)=split(/\//,$$where); + if ($$role eq 'gr') { + my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'}, + $env{'user.name'})=@_; + my ($trole) = split('_',$role,1); + (undef,my $group_privs) = split(/\//,$trole); + $group_privs = &unescape($group_privs); + } + if ($$role =~ /^cr\//) { + &custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where); + } elsif ($$role eq 'gr') { + my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'}, + $env{'user.name'}); + my $trole = split('_',$rolehash{$$where.'_'.$$role},1); + (undef,my $group_privs) = split(/\//,$trole); + $group_privs = &unescape($group_privs); + &group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart); + } else { + &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); + } + my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups); + &appenv(\%userroles,[$$role,'cm']); + &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); + $$tstatus = 'is'; + } + } + } + } + if ($$tend) { + if ($$tend<$then) { + $$tstatus='expired'; + } elsif ($$tend<$now) { + $$tstatus='will_not'; + } + } + } + } +} + +sub check_adhoc_privs { + my ($cdom,$cnum,$then,$refresh,$now,$checkrole) = @_; + my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; + if ($env{$cckey}) { + my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend); + &role_status($cckey,$then,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend); + unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) { + &set_adhoc_privileges($cdom,$cnum,$checkrole); + } + } else { + &set_adhoc_privileges($cdom,$cnum,$checkrole); + } +} + +sub set_adhoc_privileges { +# role can be cc or ca + my ($dcdom,$pickedcourse,$role) = @_; + my $area = '/'.$dcdom.'/'.$pickedcourse; + my $spec = $role.'.'.$area; + my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'}, + $env{'user.name'}); + my %ccrole = (); + &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area); + my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole); + &appenv(\%userroles,[$role,'cm']); + &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); + &appenv( {'request.role' => $spec, + 'request.role.domain' => $dcdom, + 'request.course.sec' => '' + } + ); + my $tadv=0; + if (&allowed('adv') eq 'F') { $tadv=1; } + &appenv({'request.role.adv' => $tadv}); +} + # --------------------------------------------------------------- get interface sub get { @@ -4890,7 +5082,7 @@ sub allowed { my $envkey; if ($thisallowed=~/L/) { - foreach $envkey (keys %env) { + foreach $envkey (keys(%env)) { if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { my $courseid=$2; my $roleid=$1.'.'.$2; @@ -5181,7 +5373,7 @@ sub fetch_enrollment_query { } my $host=&hostname($homeserver); my $cmd = ''; - foreach my $affiliate (keys %{$affiliatesref}) { + foreach my $affiliate (keys(%{$affiliatesref})) { $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; } $cmd =~ s/%%$//; @@ -5508,7 +5700,40 @@ sub auto_instcode_defaults { } return $response; -} +} + +sub auto_possible_instcodes { + my ($domain,$codetitles,$cat_titles,$cat_orders) = @_; + my (@homeservers,$uhome); + if (defined(&domain($domain,'primary'))) { + $uhome=&domain($domain,'primary'); + push(@homeservers,&domain($domain,'primary')); + } else { + my %servers = &get_servers($domain,'library'); + foreach my $tryserver (keys(%servers)) { + if (!grep(/^\Q$tryserver\E$/,@homeservers)) { + push(@homeservers,$tryserver); + } + } + } + my $response; + foreach my $server (@homeservers) { + $response=&reply('autopossibleinstcodes:'.$domain,$server); + next if ($response =~ /(con_lost|error|no_such_host|refused)/); + my ($codetitlestr,$cat_title,$cat_order) = split(':',$response); + @{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr)); + foreach my $item (split('&',$cat_title)) { + my ($name,$value)=split('=',$item); + $cat_titles->{&unescape($name)}=&thaw_unescape($value); + } + foreach my $item (split('&',$cat_order)) { + my ($name,$value)=split('=',$item); + $cat_orders->{&unescape($name)}=&thaw_unescape($value); + } + return 'ok'; + } + return $response; +} sub auto_validate_class_sec { my ($cdom,$cnum,$owners,$inst_class) = @_; @@ -5661,16 +5886,19 @@ sub devalidate_getgroups_cache { # ------------------------------------------------------------------ Plain Text sub plaintext { - my ($short,$type,$cid) = @_; + my ($short,$type,$cid,$forcedefault) = @_; if ($short =~ /^cr/) { return (split('/',$short))[-1]; } if (!defined($cid)) { $cid = $env{'request.course.id'}; } - if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) { - return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short. - '.plaintext'}); + if (defined($cid) && ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '')) { + unless ($forcedefault) { + my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'}; + &Apache::lonlocal::mt_escape(\$roletext); + return &Apache::lonlocal::mt($roletext); + } } my %rolenames = ( Course => 'std', @@ -5891,7 +6119,21 @@ sub modifyuser { if ($email=~/\@/) { $names{'permanentemail'} = $email; } } if ($uid) { $names{'id'} = $uid; } - if (defined($inststatus)) { $names{'inststatus'} = $inststatus; } + if (defined($inststatus)) { + $names{'inststatus'} = ''; + my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom); + if (ref($usertypes) eq 'HASH') { + my @okstatuses; + foreach my $item (split(/:/,$inststatus)) { + if (defined($usertypes->{$item})) { + push(@okstatuses,$item); + } + } + if (@okstatuses) { + $names{'inststatus'} = join(':', map { &escape($_); } @okstatuses); + } + } + } my $reply = &put('environment', \%names, $udom,$uname); if ($reply ne 'ok') { return 'error: '.$reply; } my $sqlresult = &update_allusers_table($uname,$udom,\%names); @@ -5913,7 +6155,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)=@_; + $selfenroll,$context,$inststatus)=@_; if (!$cid) { unless ($cid=$env{'request.course.id'}) { return 'not_in_class'; @@ -5922,7 +6164,7 @@ sub modifystudent { # --------------------------------------------------------------- Make the user my $reply=&modifyuser ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, - $desiredhome,$email); + $desiredhome,$email,$inststatus); unless ($reply eq 'ok') { return $reply; } # This will cause &modify_student_enrollment to get the uid from the # students environment @@ -7672,7 +7914,7 @@ sub symblist { if (($env{'request.course.fn'}) && (%newhash)) { if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', &GDBM_WRCREAT(),0640)) { - foreach my $url (keys %newhash) { + foreach my $url (keys(%newhash)) { next if ($url eq 'last_known' && $env{'form.no_update_last_known'}); $hash{declutter($url)}=&encode_symb($mapname, @@ -9010,23 +9252,31 @@ sub get_dns { return %iphost; } -} -# -# Given a DNS returns the loncapa host name for that DNS -# -sub host_from_dns { - my ($dns) = @_; - my @hosts; - my $ip; - - $ip = gethostbyname($dns); # Initial translation to IP is in net order. - if (length($ip) == 4) { - $ip = &IO::Socket::inet_ntoa($ip); - @hosts = get_hosts_from_ip($ip); - return $hosts[0]; + # + # Given a DNS returns the loncapa host name for that DNS + # + sub host_from_dns { + my ($dns) = @_; + my @hosts; + my $ip; + + if (exists($name_to_ip{$dns})) { + $ip = $name_to_ip{$dns}; + } + if (!$ip) { + $ip = gethostbyname($dns); # Initial translation to IP is in net order. + if (length($ip) == 4) { + $ip = &IO::Socket::inet_ntoa($ip); + } + } + if ($ip) { + @hosts = get_hosts_from_ip($ip); + return $hosts[0]; + } + return undef; } - return undef; + } BEGIN { @@ -9308,9 +9558,11 @@ in the user's environment.db and in %env =item * X -B: removes all items from the session -environment file that matches the regular expression in $regexp. The -values are also delted from the current processes %env. +B: removes all items from the session +environment file that begin with $delthis. If the +optional second arg - $regexp - is true, $delthis is treated as a +regular expression, otherwise \Q$delthis\E is used. +The values are also deleted from the current processes %env. =item * get_env_multiple($name) @@ -9407,9 +9659,14 @@ and course level =item * -plaintext($short) : return value in %prp hash (rolesplain.tab); plain text -explanation of a user role term - +plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash +(rolesplain.tab); plain text explanation of a user role term. +$type is Course (default) or Group. +If $forcedefault evaluates to true, text returned will be default +text for $type. Otherwise, if this is a course, the text returned +will be a custom name for the role (if defined in the course's +environment). If no custom name is defined the default is returned. + =item * get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) :