--- loncom/lonnet/perl/lonnet.pm	2009/04/11 14:47:51	1.993
+++ loncom/lonnet/perl/lonnet.pm	2009/07/17 13:55:10	1.1004
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.993 2009/04/11 14:47:51 raeburn Exp $
+# $Id: lonnet.pm,v 1.1004 2009/07/17 13:55:10 droeschl Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -718,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;
 }
@@ -1861,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*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
@@ -1904,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);
     }
@@ -2166,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'};
@@ -2551,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).
@@ -2706,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;
@@ -2728,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; }
@@ -2781,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') {
@@ -2829,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) {
@@ -3401,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});
       }
@@ -3837,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;
@@ -3880,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 {
@@ -4936,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;
@@ -5227,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/%%$//;
@@ -5554,7 +5700,40 @@ sub auto_instcode_defaults {
     }
 
     return $response;
-} 
+}
+
+sub auto_possible_instcodes {
+    my ($domain,$codetitles,$cat_titles,$cat_order) = @_;
+    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)}=&unescape($value);
+        }
+        foreach my $item (split('&',$cat_order)) {
+            my ($name,$value)=split('&',$item);
+            $cat_order->{&unescape($name)}=&unescape($value);
+        }
+        return 'ok';
+    }
+    return $response;
+}
 
 sub auto_validate_class_sec {
     my ($cdom,$cnum,$owners,$inst_class) = @_;
@@ -7735,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,