--- loncom/lonnet/perl/lonnet.pm	2005/11/15 22:02:58	1.679
+++ loncom/lonnet/perl/lonnet.pm	2006/01/05 19:39:52	1.683.2.5
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.679 2005/11/15 22:02:58 raeburn Exp $
+# $Id: lonnet.pm,v 1.683.2.5 2006/01/05 19:39:52 albertel Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -40,8 +40,8 @@ qw(%perlvar %hostname %badServerCache %i
    %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf
    %domaindescription %domain_auth_def %domain_auth_arg_def 
-   %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit
-   %env);
+   %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary
+   $tmpdir $_64bit %env);
 
 use IO::Socket;
 use GDBM_File;
@@ -1853,28 +1853,25 @@ sub courseiddump {
 # ---------------------------------------------------------- DC e-mail
 
 sub dcmailput {
-    my ($domain,$msgid,$contents,$server)=@_;
+    my ($domain,$msgid,$message,$server)=@_;
     my $status = &Apache::lonnet::critical(
        'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='.
-       &Apache::lonnet::escape($$contents{$server}),$server);
+       &Apache::lonnet::escape($message),$server);
     return $status;
 }
 
 sub dcmaildump {
     my ($dom,$startdate,$enddate,$senders) = @_;
-    my %returnhash=(); 
-    foreach my $tryserver (keys(%libserv)) {
-        if ($hostdom{$tryserver} eq $dom) {
-            %{$returnhash{$tryserver}}=();
-	    my $cmd='dcmaildump:'.$dom.':'.
-		&escape($startdate).':'.&escape($enddate).':';
-	    my @esc_senders=map { &escape($_)} @$senders;
-	    $cmd.=&escape(join('&',@esc_senders));
-	    foreach (split(/\&/,&reply($cmd,$tryserver))) {
-                my ($key,$value) = split(/\=/,$_);
-                if (($key) && ($value)) {
-                    $returnhash{$tryserver}{&unescape($key)} = &unescape($value);
-                }
+    my %returnhash=();
+    if (exists($domain_primary{$dom})) {
+        my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
+                                                         &escape($enddate).':';
+	my @esc_senders=map { &escape($_)} @$senders;
+	$cmd.=&escape(join('&',@esc_senders));
+	foreach (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {
+            my ($key,$value) = split(/\=/,$_);
+            if (($key) && ($value)) {
+                $returnhash{&unescape($key)} = &unescape($value);
             }
         }
     }
@@ -2693,21 +2690,19 @@ sub set_userprivs {
     my $author=0;
     my $adv=0;
     my %grouproles = ();
-    my %groups_checked = ();
     if (keys(%{$allgroups}) > 0) {
         foreach my $role (keys %{$allroles}) {
-            my ($trole,$area);
-            if ($role =~ m|^(\w+)\.(/\w+/\w+)|) {
+            my ($trole,$area,$sec,$extendedarea);
+            if ($role =~ m|^(\w+)\.(/\w+/\w+)(/?\w*)|) {
                 $trole = $1;
                 $area = $2;
-                unless ($groups_checked{$area}) {
-                    $groups_checked{$area} = 1;
-                    if (exists($$allgroups{$area})) {
-                        foreach my $group (keys(%{$$allgroups{$area}})) {
-                            my $spec = $trole.'.'.$area;
-                            $grouproles{$spec.'.'.$area.'/'.$group} = 
-                                                    $$allgroups{$area}{$group};
-                        }
+                $sec = $3;
+                $extendedarea = $area.$sec;
+                if (exists($$allgroups{$area})) {
+                    foreach my $group (keys(%{$$allgroups{$area}})) {
+                        my $spec = $trole.'.'.$extendedarea;
+                        $grouproles{$spec.'.'.$area.'/'.$group} = 
+                                                $$allgroups{$area}{$group};
                     }
                 }
             }
@@ -3015,8 +3010,9 @@ sub tmpput {
 
 # ------------------------------------------------------------ tmpget interface
 sub tmpget {
-    my ($token)=@_;
-    my $rep=&reply("tmpget:$token",$perlvar{'lonHostID'});
+    my ($token,$server)=@_;
+    if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
+    my $rep=&reply("tmpget:$token",$server);
     my %returnhash;
     foreach my $item (split(/\&/,$rep)) {
 	my ($key,$value)=split(/=/,$item);
@@ -3025,6 +3021,13 @@ sub tmpget {
     return %returnhash;
 }
 
+# ------------------------------------------------------------ tmpget interface
+sub tmpdel {
+    my ($token,$server)=@_;
+    if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
+    return &reply("tmpdel:$token",$server);
+}
+
 # ---------------------------------------------- Custom access rule evaluation
 
 sub customaccess {
@@ -3343,17 +3346,21 @@ sub allowed {
        my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
 	   =~/\Q$rolecode\E/) {
-           &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
-                'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
-                $env{'request.course.id'});
+	   if ($priv ne 'pch') { 
+	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
+			'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
+			$env{'request.course.id'});
+	   }
            return '';
        }
 
        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
 	   =~/\Q$unamedom\E/) {
-           &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
-                'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
-                $env{'request.course.id'});
+	   if ($priv ne 'pch') { 
+	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
+			'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
+			$env{'request.course.id'});
+	   }
            return '';
        }
    }
@@ -3363,9 +3370,11 @@ sub allowed {
    if ($thisallowed=~/R/) {
        my $rolecode=(split(/\./,$env{'request.role'}))[0];
        if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
-	   &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
-		'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
-          return '';
+	   if ($priv ne 'pch') { 
+	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
+			'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
+	   }
+	   return '';
        }
    }
 
@@ -3705,24 +3714,8 @@ sub auto_instcode_format {
 # ------------------------------------------------------- Course Group routines
 
 sub get_coursegroups {
-    my ($cdom,$cnum,$curr_groups,$group) = @_;
-    my $numgroups = 0;
-    %{$curr_groups} = &dump('coursegroups',$cdom,$cnum,$group);
-    my ($tmp)=keys(%{$curr_groups});
-    if ($tmp eq 'error: 2 tie(GDBM) Failed while attempting dump') {
-        my %emptyhash = ();
-        if (&put('coursegroups',\%emptyhash,$cdom,$cnum) eq 'ok') {
-            %{$curr_groups} = &dump('coursegroups',$cdom,$cnum,$group);
-            $tmp=keys(%{$curr_groups});
-        }
-    }
-    if ($tmp=~/^error:/) {
-        &logthis('Error retrieving groups: '.$tmp.' in '.$cnum.':'.$cdom);
-    } else {
-        my @groups = keys(%{$curr_groups});
-        $numgroups = @groups;
-    }
-    return $numgroups;
+    my ($cdom,$cnum,$group) = @_;
+    return(&dump('coursegroups',$cdom,$cnum,$group));
 }
 
 sub modify_coursegroup {
@@ -3745,6 +3738,66 @@ sub modify_coursegroup_membership {
     return $result;
 }
 
+sub get_active_groups {
+    my ($udom,$uname,$cdom,$cnum) = @_;
+    my $now = time;
+    my %groups = ();
+    foreach my $key (keys(%env)) {
+        if ($key =~ m-user\.role\.gr\./([^/]+)/([^/]+)/(\w+)$-) {
+            my ($start,$end) = split(/\./,$env{$key});
+            if (($end!=0) && ($end<$now)) { next; }
+            if (($start!=0) && ($start>$now)) { next; }
+            if ($1 eq $cdom && $2 eq $cnum) {
+                $groups{$3} = $env{$key} ;
+            }
+        }
+    }
+    return %groups;
+}
+
+sub get_group_membership {
+    my ($cdom,$cnum,$group) = @_;
+    return(&dump('groupmembership',$cdom,$cnum,$group));
+}
+
+sub get_users_groups {
+    my ($udom,$uname,$courseid) = @_;
+    my $cachetime=1800;
+    $courseid=~s/\_/\//g;
+    $courseid=~s/^(\w)/\/$1/;
+
+    my $hashid="$udom:$uname:$courseid";
+    my ($result,$cached)=&is_cached_new('getgroups',$hashid);
+    if (defined($cached)) { return $result; }
+
+    my %roleshash = &dump('roles',$udom,$uname,$courseid);
+    my ($tmp) = keys(%roleshash);
+    if ($tmp=~/^error:/) {
+        &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);
+        return '';
+    } else {
+        my $grouplist;
+        foreach my $key (keys %roleshash) {
+            if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
+                unless ($roleshash{$key} =~ /_1_1$/) {   # deleted membership
+                    $grouplist .= $1.':';
+                }
+            }
+        }
+        $grouplist =~ s/:$//;
+        return &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
+    }
+}
+
+sub devalidate_getgroups_cache {
+    my ($udom,$uname,$cdom,$cnum)=@_;
+    my $courseid = $cdom.'_'.$cnum;
+    $courseid=~s/\_/\//g;
+    $courseid=~s/^(\w)/\/$1/;
+    my $hashid="$udom:$uname:$courseid";
+    &devalidate_cache_new('getgroups',$hashid);
+}
+
 # ------------------------------------------------------------------ Plain Text
 
 sub plaintext {
@@ -3937,6 +3990,7 @@ sub modifyuser {
     }
     my $reply = &put('environment', \%names, $udom,$uname);
     if ($reply ne 'ok') { return 'error: '.$reply; }
+    &devalidate_cache_new('namescache',$uname.':'.$udom);
     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
              $umode.', '.$first.', '.$middle.', '.
 	     $last.', '.$gene.' by '.
@@ -5369,6 +5423,9 @@ sub symbread {
         if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {
             $targetfn = 'adm/wrapper/'.$thisfn;
         }
+	if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {
+	    $targetfn=$1;
+	}
         if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
                       &GDBM_READER(),0640)) {
 	    $syval=$hash{$targetfn};
@@ -6142,7 +6199,7 @@ BEGIN {
 #           next if /^\#/;
            chomp;
            my ($domain, $domain_description, $def_auth, $def_auth_arg,
-	       $def_lang, $city, $longi, $lati) = split(/:/,$_);
+	       $def_lang, $city, $longi, $lati, $primary) = split(/:/,$_);
 	   $domain_auth_def{$domain}=$def_auth;
            $domain_auth_arg_def{$domain}=$def_auth_arg;
 	   $domaindescription{$domain}=$domain_description;
@@ -6150,6 +6207,7 @@ BEGIN {
 	   $domain_city{$domain}=$city;
 	   $domain_longi{$domain}=$longi;
 	   $domain_lati{$domain}=$lati;
+           $domain_primary{$domain}=$primary;
 
  #         &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
 #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
@@ -6176,7 +6234,7 @@ BEGIN {
     }
     close($config);
     # FIXME: dev server don't want this, production servers _do_ want this
-    #&get_iphost();
+    &get_iphost();
 }
 
 sub get_iphost {