--- loncom/lonnet/perl/lonnet.pm	2009/03/09 03:49:17	1.989
+++ loncom/lonnet/perl/lonnet.pm	2009/05/16 01:19:36	1.1001
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.989 2009/03/09 03:49:17 raeburn Exp $
+# $Id: lonnet.pm,v 1.1001 2009/05/16 01:19:36 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)=@_;
@@ -693,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;
 }
@@ -1879,7 +1909,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);
     }
@@ -2141,9 +2171,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'};
@@ -2526,7 +2559,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).
@@ -2681,6 +2714,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;
@@ -2703,15 +2739,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; }
@@ -2756,6 +2806,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') {
@@ -2804,9 +2855,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) {
@@ -3376,7 +3450,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});
       }
@@ -3812,7 +3886,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;
@@ -3855,6 +3929,67 @@ sub set_userprivs {
     return ($author,$adv);
 }
 
+sub role_status {
+    my ($rolekey,$then,$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<$now) { $$tstatus='will'; }
+            }
+            if ($$tend) {
+                if ($$tend<$then) {
+                    $$tstatus='expired';
+                } elsif ($$tend<$now) {
+                    $$tstatus='will_not';
+                }
+            }
+        }
+    }
+}
+
+sub check_adhoc_privs {
+    my ($cdom,$cnum,$then,$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,$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 {
@@ -4911,7 +5046,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;
@@ -5202,7 +5337,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/%%$//;
@@ -5951,7 +6086,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';
@@ -5960,7 +6095,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
@@ -7710,7 +7845,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,
@@ -9048,23 +9183,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 {