--- loncom/lonnet/perl/lonnet.pm	2006/05/01 06:17:32	1.733
+++ loncom/lonnet/perl/lonnet.pm	2006/06/02 21:32:30	1.743
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.733 2006/05/01 06:17:32 raeburn Exp $
+# $Id: lonnet.pm,v 1.743 2006/06/02 21:32:30 albertel Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -38,7 +38,7 @@ use vars
 qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom 
    %libserv %pr %prp $memcache %packagetab 
    %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount 
-   %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf
+   %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
    %domaindescription %domain_auth_def %domain_auth_arg_def 
    %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary
    $tmpdir $_64bit %env);
@@ -52,6 +52,9 @@ use Storable qw(lock_store lock_nstore l
 use Time::HiRes qw( gettimeofday tv_interval );
 use Cache::Memcached;
 use Digest::MD5;
+use lib '/home/httpd/lib/perl';
+use LONCAPA;
+use LONCAPA::Configuration;
 
 my $readit;
 my $max_connection_retries = 10;     # Or some such value.
@@ -1384,7 +1387,22 @@ sub userfileupload {
         open(my $fh,'>'.$fullpath.'/'.$fname);
         print $fh $env{'form.'.$formname};
         close($fh);
-        return $fullpath.'/'.$fname; 
+        return $fullpath.'/'.$fname;
+    } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { #files uploaded to create course page are handled differently
+        my $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.
+                       '_'.$env{'user.domain'}.'/pending';
+        my @parts=split(/\//,$filepath);
+        my $fullpath = $perlvar{'lonDaemons'};
+        for (my $i=0;$i<@parts;$i++) {
+            $fullpath .= '/'.$parts[$i];
+            if ((-e $fullpath)!=1) {
+                mkdir($fullpath,0777);
+            }
+        }
+        open(my $fh,'>'.$fullpath.'/'.$fname);
+        print $fh $env{'form.'.$formname};
+        close($fh);
+        return $fullpath.'/'.$fname;
     }
     
 # Create the directory if not present
@@ -1648,11 +1666,11 @@ sub flushcourselogs {
         if ($courseidbuffer{$coursehombuf{$crsid}}) {
            $courseidbuffer{$coursehombuf{$crsid}}.='&'.
 			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
-                         ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid});
+                         ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
         } else {
            $courseidbuffer{$coursehombuf{$crsid}}=
 			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
-                         ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid});
+                         ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
         }
     }
 #
@@ -1755,6 +1773,8 @@ sub courselog {
        $env{'course.'.$env{'request.course.id'}.'.internal.coursecode'};
     $courseownerbuf{$env{'request.course.id'}}=
        $env{'course.'.$env{'request.course.id'}.'.internal.courseowner'};
+    $coursetypebuf{$env{'request.course.id'}}=
+       $env{'course.'.$env{'request.course.id'}.'.type'};
     if (defined $courselogs{$env{'request.course.id'}}) {
 	$courselogs{$env{'request.course.id'}}.='&'.$what;
     } else {
@@ -1925,7 +1945,7 @@ sub courseidput {
 }
 
 sub courseiddump {
-    my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref)=@_;
+    my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter)=@_;
     my %returnhash=();
     unless ($domfilter) { $domfilter=''; }
     foreach my $tryserver (keys %libserv) {
@@ -1934,7 +1954,7 @@ sub courseiddump {
 	        foreach (
                  split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
 			       $sincefilter.':'.&escape($descfilter).':'.
-                               &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter),
+                               &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter),
                                $tryserver))) {
 		    my ($key,$value)=split(/\=/,$_);
                     if (($key) && ($value)) {
@@ -1952,8 +1972,8 @@ sub courseiddump {
 sub dcmailput {
     my ($domain,$msgid,$message,$server)=@_;
     my $status = &Apache::lonnet::critical(
-       'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='.
-       &Apache::lonnet::escape($message),$server);
+       'dcmailput:'.$domain.':'.&escape($msgid).'='.
+       &escape($message),$server);
     return $status;
 }
 
@@ -2637,6 +2657,9 @@ sub coursedescription {
            $returnhash{'home'}= $chome;
 	   $returnhash{'domain'} = $cdomain;
 	   $returnhash{'num'} = $cnum;
+           if (!defined($returnhash{'type'})) {
+               $returnhash{'type'} = 'Course';
+           }
            while (my ($name,$value) = each %returnhash) {
                $envhash{'course.'.$normalid.'.'.$name}=$value;
            }
@@ -2693,7 +2716,7 @@ sub rolesinit {
     my %allroles=();
     my %allgroups=();   
     my $now=time;
-    my $userroles="user.login.time=$now\n";
+    my %userroles = ('user.login.time' => $now);
     my $group_privs;
 
     if ($rolesdump ne '') {
@@ -2716,7 +2739,9 @@ sub rolesinit {
 	    } else {
 		($trole,$tend,$tstart)=split(/_/,$role);
 	    }
-            $userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username);
+	    my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
+					 $username);
+	    @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
             if (($tend!=0) && ($tend<$now)) { $trole=''; }
             if (($tstart!=0) && ($tstart>$now)) { $trole=''; }
             if (($area ne '') && ($trole ne '')) {
@@ -2732,19 +2757,19 @@ sub rolesinit {
             }
           }
         }
-        my ($author,$adv) = &set_userprivs(\$userroles,\%allroles,\%allgroups);
-        $userroles.='user.adv='.$adv."\n".
-	            'user.author='.$author."\n";
+        my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups);
+        $userroles{'user.adv'}    = $adv;
+	$userroles{'user.author'} = $author;
         $env{'user.adv'}=$adv;
     }
-    return $userroles;  
+    return \%userroles;  
 }
 
 sub set_arearole {
     my ($trole,$area,$tstart,$tend,$domain,$username) = @_;
 # log the associated role with the area
     &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
-    return 'user.role.'.$trole.'.'.$area.'='.$tstart.'.'.$tend."\n";
+    return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);
 }
 
 sub custom_roleprivs {
@@ -2846,7 +2871,7 @@ sub set_userprivs {
         }
         my $thesestr='';
         foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }
-        $$userroles.='user.priv.'.$_.'='.$thesestr."\n";
+        $userroles->{'user.priv.'.$_} = $thesestr;
     }
     return ($author,$adv);
 }
@@ -3982,7 +4007,6 @@ sub modify_group_roles {
     if ($result eq 'ok') {
         &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
     }
-
     return $result;
 }
 
@@ -4024,7 +4048,7 @@ sub get_users_groups {
     my $hashid="$udom:$uname:$courseid";
     my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
     if (defined($cached)) {
-        @usersgroups = split/:/,$grouplist;
+        @usersgroups = split(/:/,$grouplist);
     } else {  
         $grouplist = '';
         my %roleshash = &dump('roles',$udom,$uname,$courseid);
@@ -4035,7 +4059,7 @@ sub get_users_groups {
             my $access_end = $env{'course.'.$courseid.
                                   '.default_enrollment_end_date'};
             my $now = time;
-            foreach my $key (keys %roleshash) {
+            foreach my $key (keys(%roleshash)) {
                 if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
                     my $group = $1;
                     if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
@@ -4075,8 +4099,25 @@ sub devalidate_getgroups_cache {
 # ------------------------------------------------------------------ Plain Text
 
 sub plaintext {
-    my $short=shift;
-    return &Apache::lonlocal::mt($prp{$short});
+    my ($short,$type,$cid) = @_;
+    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'});
+    }
+    my %rolenames = (
+                      Course => 'std',
+                      Group => 'alt1',
+                    );
+    if (defined($type) && 
+         defined($rolenames{$type}) && 
+         defined($prp{$short}{$rolenames{$type}})) {
+        return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});
+    } else {
+        return &Apache::lonlocal::mt($prp{$short}{'std'});
+    }
 }
 
 # ----------------------------------------------------------------- Assign Role
@@ -4125,6 +4166,8 @@ sub assignrole {
            $command.='_0_'.$start;
         }
     }
+    my $origstart = $start;
+    my $origend = $end;
 # actually delete
     if ($deleteflag) {
 	if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
@@ -4142,6 +4185,11 @@ sub assignrole {
 # log new user role if status is ok
     if ($answer eq 'ok') {
 	&userrolelog($role,$uname,$udom,$url,$start,$end);
+# for course roles, perform group memberships changes triggered by role change.
+        unless ($role =~ /^gr/) {
+            &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
+                                             $origstart);
+        }
     }
     return $answer;
 }
@@ -4398,7 +4446,8 @@ sub writecoursepref {
 # ---------------------------------------------------------- Make/modify course
 
 sub createcourse {
-    my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner)=@_;
+    my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
+        $course_owner,$crstype)=@_;
     $url=&declutter($url);
     my $cid='';
     unless (&allowed('ccc',$udom)) {
@@ -4435,7 +4484,8 @@ sub createcourse {
 # ----------------------------------------------------------------- Course made
 # log existence
     &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
-                 ':'.&escape($inst_code).':'.&escape($course_owner),$uhome);
+                 ':'.&escape($inst_code).':'.&escape($course_owner).':'.
+                  &escape($crstype),$uhome);
     &flushcourselogs();
 # set toplevel url
     my $topurl=$url;
@@ -4818,7 +4868,7 @@ sub stat_file {
 	($udom,$uname,$file) =
 	    ($uri =~ m-/(?:uploaded|editupload)/?([^/]*)/?([^/]*)/?(.*)-);
 	$file = 'userfiles/'.$file;
-	$dir = &Apache::loncommon::propath($udom,$uname);
+	$dir = &propath($udom,$uname);
     }
     if ($uri =~ m-^/res/-) {
 	($udom,$uname) = 
@@ -5171,7 +5221,7 @@ sub EXT {
 
 # ----------------------------------------------------- Cascading lookup scheme
 	    my $symbp=$symbparm;
-	    my $mapp=(&decode_symb($symbp))[0];
+	    my $mapp=&deversion((&decode_symb($symbp))[0]);
 
 	    my $symbparm=$symbp.'.'.$spacequalifierrest;
 	    my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
@@ -5319,9 +5369,29 @@ sub sort_course_groups { # Sort groups b
 sub packages_tab_default {
     my ($uri,$varname)=@_;
     my (undef,$part,$name)=split(/\./,$varname);
-    my $packages=&metadata($uri,'packages');
-    foreach my $package (split(/,/,$packages)) {
+
+    my (@extension,@specifics,$do_default);
+    foreach my $package (split(/,/,&metadata($uri,'packages'))) {
 	my ($pack_type,$pack_part)=split(/_/,$package,2);
+	if ($pack_type eq 'default') {
+	    $do_default=1;
+	} elsif ($pack_type eq 'extension') {
+	    push(@extension,[$package,$pack_type,$pack_part]);
+	} else {
+	    push(@specifics,[$package,$pack_type,$pack_part]);
+	}
+    }
+    # first look for a package that matches the requested part id
+    foreach my $package (@specifics) {
+	my (undef,$pack_type,$pack_part)=@{$package};
+	next if ($pack_part ne $part);
+	if (defined($packagetab{"$pack_type&$name&default"})) {
+	    return $packagetab{"$pack_type&$name&default"};
+	}
+    }
+    # look for any possible matching non extension_ package
+    foreach my $package (@specifics) {
+	my (undef,$pack_type,$pack_part)=@{$package};
 	if (defined($packagetab{"$pack_type&$name&default"})) {
 	    return $packagetab{"$pack_type&$name&default"};
 	}
@@ -5330,6 +5400,20 @@ sub packages_tab_default {
 	    return $packagetab{$pack_type."_".$pack_part."&$name&default"};
 	}
     }
+    # look for any posible extension_ match
+    foreach my $package (@extension) {
+	my ($package,$pack_type)=@{$package};
+	if (defined($packagetab{"$pack_type&$name&default"})) {
+	    return $packagetab{"$pack_type&$name&default"};
+	}
+	if (defined($packagetab{$package."&$name&default"})) {
+	    return $packagetab{$package."&$name&default"};
+	}
+    }
+    # look for a global default setting
+    if ($do_default && defined($packagetab{"default&$name&default"})) {
+	return $packagetab{"default&$name&default"};
+    }
     return undef;
 }
 
@@ -5415,16 +5499,16 @@ sub metadata {
 		    } else {
 			$metaentry{':packages'}=$package.$keyroot;
 		    }
-		    foreach (sort keys %packagetab) {
+		    foreach my $pack_entry (keys(%packagetab)) {
 			my $part=$keyroot;
 			$part=~s/^\_//;
-			if ($_=~/^\Q$package\E\&/ || 
-			    $_=~/^\Q$package\E_0\&/) {
-			    my ($pack,$name,$subp)=split(/\&/,$_);
+			if ($pack_entry=~/^\Q$package\E\&/ || 
+			    $pack_entry=~/^\Q$package\E_0\&/) {
+			    my ($pack,$name,$subp)=split(/\&/,$pack_entry);
 			    # ignore package.tab specified default values
                             # here &package_tab_default() will fetch those
 			    if ($subp eq 'default') { next; }
-			    my $value=$packagetab{$_};
+			    my $value=$packagetab{$pack_entry};
 			    my $unikey;
 			    if ($pack =~ /_0$/) {
 				$unikey='parameter_0_'.$name;
@@ -5472,11 +5556,12 @@ sub metadata {
 			    my $dir=$filename;
 			    $dir=~s|[^/]*$||;
 			    $location=&filelocation($dir,$location);
-			    foreach (sort(split(/\,/,&metadata($uri,'keys',
-							       $location,$unikey,
-							       $depthcount+1)))) {
-				$metaentry{':'.$_}=$metaentry{':'.$_};
-				$metathesekeys{$_}=1;
+			    my $metadata = 
+				&metadata($uri,'keys', $location,$unikey,
+					  $depthcount+1);
+			    foreach my $meta (split(',',$metadata)) {
+				$metaentry{':'.$meta}=$metaentry{':'.$meta};
+				$metathesekeys{$meta}=1;
 			    }
 			}
 		    } else { 
@@ -5485,8 +5570,9 @@ sub metadata {
 			    $unikey.='_'.$token->[2]->{'name'}; 
 			}
 			$metathesekeys{$unikey}=1;
-			foreach (@{$token->[3]}) {
-			    $metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_};
+			foreach my $param (@{$token->[3]}) {
+			    $metaentry{':'.$unikey.'.'.$param} =
+				$token->[2]->{$param};
 			}
 			my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
 			my $default=$metaentry{':'.$unikey.'.default'};
@@ -5507,14 +5593,14 @@ sub metadata {
 	    }
 	}
 	my ($extension) = ($uri =~ /\.(\w+)$/);
-	foreach my $key (sort(keys(%packagetab))) {
+	foreach my $key (keys(%packagetab)) {
 	    #no specific packages #how's our extension
 	    if ($key!~/^extension_\Q$extension\E&/) { next; }
 	    &metadata_create_package_def($uri,$key,'extension_'.$extension,
 					 \%metathesekeys);
 	}
 	if (!exists($metaentry{':packages'})) {
-	    foreach my $key (sort(keys(%packagetab))) {
+	    foreach my $key (keys(%packagetab)) {
 		#no specific packages well let's get default then
 		if ($key!~/^default&/) { next; }
 		&metadata_create_package_def($uri,$key,'default',
@@ -5532,15 +5618,22 @@ sub metadata {
 		my $dir=$filename;
 		$dir=~s|[^/]*$||;
 		$location=&filelocation($dir,$location);
-		foreach (sort(split(/\,/,&metadata($uri,'keys',
-						   $location,'_rights',
-						   $depthcount+1)))) {
-		    #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_};
-		    $metathesekeys{$_}=1;
+		my $rights_metadata =
+		    &metadata($uri,'keys',$location,'_rights',
+			      $depthcount+1);
+		foreach my $rights (split(',',$rights_metadata)) {
+		    #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
+		    $metathesekeys{$rights}=1;
 		}
 	    }
 	}
-	$metaentry{':keys'}=join(',',keys %metathesekeys);
+	# uniqifiy package listing
+	my %seen;
+	my @uniq_packages =
+	    grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
+	$metaentry{':packages'} = join(',',@uniq_packages);
+
+	$metaentry{':keys'} = join(',',keys(%metathesekeys));
 	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
 	$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
 	&do_cache_new('meta',$uri,\%metaentry,60*60);
@@ -5576,7 +5669,7 @@ sub metadata_create_package_def {
 sub metadata_generate_part0 {
     my ($metadata,$metacache,$uri) = @_;
     my %allnames;
-    foreach my $metakey (sort keys %$metadata) {
+    foreach my $metakey (keys(%$metadata)) {
 	if ($metakey=~/^parameter\_(.*)/) {
 	  my $part=$$metacache{':'.$metakey.'.part'};
 	  my $name=$$metacache{':'.$metakey.'.name'};
@@ -6411,7 +6504,7 @@ sub filelocation {
         my @ids=&current_machine_ids();
         foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
         if ($is_me) {
-  	    $location=&Apache::loncommon::propath($udom,$uname).
+  	    $location=&propath($udom,$uname).
   	      '/userfiles/'.$filename;
         } else {
   	  $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
@@ -6532,21 +6625,6 @@ sub freeze_escape {
     return &escape($value);
 }
 
-# -------------------------------------------------------- Escape Special Chars
-
-sub escape {
-    my $str=shift;
-    $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
-    return $str;
-}
-
-# ----------------------------------------------------- Un-Escape Special Chars
-
-sub unescape {
-    my $str=shift;
-    $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
-    return $str;
-}
 
 sub thaw_unescape {
     my ($value)=@_;
@@ -6720,8 +6798,14 @@ sub get_iphost {
     while (my $configline=<$config>) {
 	chomp($configline);
 	if ($configline) {
-	    my ($short,$plain)=split(/:/,$configline);
-	    if ($plain ne '') { $prp{$short}=$plain; }
+	    my ($short,@plain)=split(/:/,$configline);
+            %{$prp{$short}} = ();
+	    if (@plain > 0) {
+                $prp{$short}{'std'} = $plain[0];
+                for (my $i=1; $i<@plain; $i++) {
+                    $prp{$short}{'alt'.$i} = $plain[$i];  
+                }
+            }
 	}
     }
     close($config);