--- loncom/lonnet/perl/lonnet.pm	2009/03/09 05:25:44	1.990
+++ loncom/lonnet/perl/lonnet.pm	2009/04/11 21:43:02	1.994
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.990 2009/03/09 05:25:44 raeburn Exp $
+# $Id: lonnet.pm,v 1.994 2009/04/11 21:43:02 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)=@_;
@@ -3855,6 +3880,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 {
@@ -9048,23 +9134,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 {