--- loncom/lonnet/perl/lonnet.pm	2006/12/04 16:24:11	1.812
+++ loncom/lonnet/perl/lonnet.pm	2007/03/17 04:13:06	1.824.2.3
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.812 2006/12/04 16:24:11 raeburn Exp $
+# $Id: lonnet.pm,v 1.824.2.3 2007/03/17 04:13:06 albertel Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -53,7 +53,6 @@ use Time::HiRes qw( gettimeofday tv_inte
 use Cache::Memcached;
 use Digest::MD5;
 use Math::Random;
-use lib '/home/httpd/lib/perl';
 use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;
 
@@ -368,6 +367,26 @@ sub transfer_profile_to_env {
     }
 }
 
+sub timed_flock {
+    my ($file,$lock_type) = @_;
+    my $failed=0;
+    eval {
+	local $SIG{__DIE__}='DEFAULT';
+	local $SIG{ALRM}=sub {
+	    $failed=1;
+	    die("failed lock");
+	};
+	alarm(13);
+	flock($file,$lock_type);
+	alarm(0);
+    };
+    if ($failed) {
+	return undef;
+    } else {
+	return 1;
+    }
+}
+
 # ---------------------------------------------------------- Append Environment
 
 sub appenv {
@@ -382,8 +401,11 @@ sub appenv {
             $env{$key}=$newenv{$key};
         }
     }
-    if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
-	    0640)) {
+    open(my $env_file,$env{'user.environment'});
+    if (&timed_flock($env_file,LOCK_EX)
+	&&
+	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
+	    (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
 	while (my ($key,$value) = each(%newenv)) {
 	    $disk_env{$key} = $value;
 	}
@@ -400,8 +422,11 @@ sub delenv {
                 "Attempt to delete from environment ".$delthis);
         return 'error';
     }
-    if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
-	    0640)) {
+    open(my $env_file,$env{'user.environment'});
+    if (&timed_flock($env_file,LOCK_EX)
+	&&
+	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
+	    (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
 	foreach my $key (keys(%disk_env)) {
 	    if ($key=~/^$delthis/) { 
                 delete($env{$key});
@@ -878,6 +903,25 @@ sub devalidate_getsection_cache {
     &devalidate_cache_new('getsection',$hashid);
 }
 
+sub courseid_to_courseurl {
+    my ($courseid) = @_;
+    #already url style courseid
+    return $courseid if ($courseid =~ m{^/});
+
+    if (exists($env{'course.'.$courseid.'.num'})) {
+	my $cnum = $env{'course.'.$courseid.'.num'};
+	my $cdom = $env{'course.'.$courseid.'.domain'};
+	return "/$cdom/$cnum";
+    }
+
+    my %courseinfo=&Apache::lonnet::coursedescription($courseid);
+    if (exists($courseinfo{'num'})) {
+	return "/$courseinfo{'domain'}/$courseinfo{'num'}";
+    }
+
+    return undef;
+}
+
 sub getsection {
     my ($udom,$unam,$courseid)=@_;
     my $cachetime=1800;
@@ -901,14 +945,13 @@ sub getsection {
     # If there is more than one expired role, choose the one which ended last.
     # If there is a role which has expired, return it.
     #
-    foreach my $line (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
-					&homeserver($unam,$udom)))) {
-        my ($key,$value)=split(/\=/,$line,2);
-        $key=&unescape($key);
+    $courseid = &courseid_to_courseurl($courseid);
+    my %roleshash = &dump('roles',$udom,$unam,$courseid);
+    foreach my $key (keys(%roleshash)) {
         next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
         my $section=$1;
         if ($key eq $courseid.'_st') { $section=''; }
-        my ($dummy,$end,$start)=split(/\_/,&unescape($value));
+        my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key}));
         my $now=time;
         if (defined($end) && $end && ($now > $end)) {
             $Expired{$end}=$section;
@@ -947,10 +990,16 @@ my %remembered;
 my %accessed;
 my $kicks=0;
 my $hits=0;
+sub make_key {
+    my ($name,$id) = @_;
+    if (length($id) > 200) { $id=length($id).':'.&Digest::MD5::md5_hex($id); }
+    return &escape($name.':'.$id);
+}
+
 sub devalidate_cache_new {
     my ($name,$id,$debug) = @_;
     if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
-    $id=&escape($name.':'.$id);
+    $id=&make_key($name,$id);
     $memcache->delete($id);
     delete($remembered{$id});
     delete($accessed{$id});
@@ -958,7 +1007,7 @@ sub devalidate_cache_new {
 
 sub is_cached_new {
     my ($name,$id,$debug) = @_;
-    $id=&escape($name.':'.$id);
+    $id=&make_key($name,$id);
     if (exists($remembered{$id})) {
 	if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
 	$accessed{$id}=[&gettimeofday()];
@@ -981,7 +1030,7 @@ sub is_cached_new {
 
 sub do_cache_new {
     my ($name,$id,$value,$time,$debug) = @_;
-    $id=&escape($name.':'.$id);
+    $id=&make_key($name,$id);
     my $setvalue=$value;
     if (!defined($setvalue)) {
 	$setvalue='__undef__';
@@ -1684,6 +1733,12 @@ sub removeuserfile {
         if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
             my $metafile = $fname.'.meta';
             my $metaresult = &removeuserfile($docuname,$docudom,$metafile); 
+	    my $url = "/uploaded/$docudom/$docuname/$fname";
+            my ($file,$group) = (&parse_portfolio_url($url))[3,4];
+            my $sqlresult = 
+                &update_portfolio_table($docuname,$docudom,$file,
+                                        'portfolio_metadata',$group,
+                                        'delete');
         }
     }
     return $result;
@@ -1706,6 +1761,12 @@ sub renameuserfile {
             my $newmeta = $new.'.meta';
             my $metaresult = 
                 &renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
+	    my $url = "/uploaded/$docudom/$docuname/$old";
+            my ($file,$group) = (&parse_portfolio_url($url))[3,4];
+            my $sqlresult = 
+                &update_portfolio_table($docuname,$docudom,$file,
+                                        'portfolio_metadata',$group,
+                                        'delete');
         }
     }
     return $result;
@@ -3031,7 +3092,23 @@ sub dump {
 
 sub dumpstore {
    my ($namespace,$udomain,$uname,$regexp,$range)=@_;
-   return &dump($namespace,$udomain,$uname,$regexp,$range);
+   if (!$udomain) { $udomain=$env{'user.domain'}; }
+   if (!$uname) { $uname=$env{'user.name'}; }
+   my $uhome=&homeserver($uname,$udomain);
+   if ($regexp) {
+       $regexp=&escape($regexp);
+   } else {
+       $regexp='.';
+   }
+   my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
+   my @pairs=split(/\&/,$rep);
+   my %returnhash=();
+   foreach my $item (@pairs) {
+       my ($key,$value)=split(/=/,$item,2);
+       next if ($key =~ /^error: 2 /);
+       $returnhash{$key}=&thaw_unescape($value);
+   }
+   return %returnhash;
 }
 
 # -------------------------------------------------------------- keys interface
@@ -3065,7 +3142,7 @@ sub currentdump {
    if ($rep eq "unknown_cmd") { 
        # an old lond will not know currentdump
        # Do a dump and make it look like a currentdump
-       my @tmp = &dump($courseid,$sdom,$sname,'.');
+       my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
        return if ($tmp[0] =~ /^(error:|no_such_host)/);
        my %hash = @tmp;
        @tmp=();
@@ -3090,6 +3167,8 @@ sub convert_dump_to_currentdump{
     # we might run in to problems with parameter names =~ /^v\./
     while (my ($key,$value) = each(%hash)) {
         my ($v,$symb,$param) = split(/:/,$key);
+	$symb  = &unescape($symb);
+	$param = &unescape($param);
         next if ($v eq 'version' || $symb eq 'keys');
         next if (exists($returnhash{$symb}) &&
                  exists($returnhash{$symb}->{$param}) &&
@@ -3303,6 +3382,22 @@ sub portfolio_access {
     my ($requrl) = @_;
     my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
     my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
+    if ($result) {
+        my %setters;
+        if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
+            my ($startblock,$endblock) =
+                &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);
+            if ($startblock && $endblock) {
+                return 'B';
+            }
+        } else {
+            my ($startblock,$endblock) =
+                &Apache::loncommon::blockcheck(\%setters,'port');
+            if ($startblock && $endblock) {
+                return 'B';
+            }
+        }
+    }
     if ($result eq 'ok') {
        return 'F';
     } elsif ($result =~ /^[^:]+:guest_/) {
@@ -3486,12 +3581,12 @@ sub parse_portfolio_url {
 
     my ($type,$udom,$unum,$group,$file_name);
     
-    if ($url =~  m-^/*uploaded/($match_domain)/($match_username)/portfolio(/.+)$-) {
+    if ($url =~  m-^/*(?:uploaded|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) {
 	$type = 1;
         $udom = $1;
         $unum = $2;
         $file_name = $3;
-    } elsif ($url =~ m-^/*uploaded/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
+    } elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
 	$type = 2;
         $udom = $1;
         $unum = $2;
@@ -3511,7 +3606,7 @@ sub is_portfolio_url {
 
 sub is_portfolio_file {
     my ($file) = @_;
-    if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w\/portfolio/)) {
+    if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {
         return 1;
     }
     return;
@@ -3523,7 +3618,7 @@ sub is_portfolio_file {
 sub customaccess {
     my ($priv,$uri)=@_;
     my ($urole,$urealm)=split(/\./,$env{'request.role'},2);
-    my ($udom,$ucrs,$usec)=split(/\//,$urealm);
+    my (undef,$udom,$ucrs,$usec)=split(/\//,$urealm);
     $udom = &LONCAPA::clean_domain($udom);
     $ucrs = &LONCAPA::clean_username($ucrs);
     my $access=0;
@@ -3583,7 +3678,14 @@ sub allowed {
     my ($space,$domain,$name,@dir)=split('/',$uri);
     if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && 
 	($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
-        return 'F';
+        my %setters;
+        my ($startblock,$endblock) = 
+            &Apache::loncommon::blockcheck(\%setters,'port');
+        if ($startblock && $endblock) {
+            return 'B';
+        } else {
+            return 'F';
+        }
     }
 
 # bre access to group portfolio for rgf priv in group, or mdg or vcg in course.
@@ -3859,6 +3961,8 @@ sub allowed {
     unless ($env{'request.course.id'}) {
 	if ($thisallowed eq 'A') {
 	    return 'A';
+        } elsif ($thisallowed eq 'B') {
+            return 'B';
 	} else {
 	    return '1';
 	}
@@ -3926,6 +4030,8 @@ sub allowed {
 
     if ($thisallowed eq 'A') {
 	return 'A';
+    } elsif ($thisallowed eq 'B') {
+        return 'B';
     }
    return 'F';
 }
@@ -4052,6 +4158,18 @@ sub log_query {
     return get_query_reply($queryid);
 }
 
+# -------------------------- Update MySQL table for portfolio file
+
+sub update_portfolio_table {
+    my ($uname,$udom,$file_name,$query,$group,$action) = @_;
+    my $homeserver = &homeserver($uname,$udom);
+    my $queryid=
+        &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
+               ':'.&escape($file_name).':'.$action,$homeserver);
+    my $reply = &get_query_reply($queryid);
+    return $reply;
+}
+
 # ------- Request retrieval of institutional classlists for course(s)
 
 sub fetch_enrollment_query {
@@ -4467,38 +4585,34 @@ sub get_users_groups {
         @usersgroups = split(/:/,$grouplist);
     } else {  
         $grouplist = '';
-        my %roleshash = &dump('roles',$udom,$uname,$courseid);
-        my ($tmp) = keys(%roleshash);
-        if ($tmp=~/^error:/) {
-            &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);
-        } else {
-            my $access_end = $env{'course.'.$courseid.
-                                  '.default_enrollment_end_date'};
-            my $now = time;
-            foreach my $key (keys(%roleshash)) {
-                if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
-                    my $group = $1;
-                    if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
-                        my $start = $2;
-                        my $end = $1;
-                        if ($start == -1) { next; } # deleted from group
-                        if (($start!=0) && ($start>$now)) { next; }
-                        if (($end!=0) && ($end<$now)) {
-                            if ($access_end && $access_end < $now) {
-                                if ($access_end - $end < 86400) {
-                                    push(@usersgroups,$group);
-                                }
+        my $courseurl = &courseid_to_courseurl($courseid);
+        my %roleshash = &dump('roles',$udom,$uname,$courseurl);
+        my $access_end = $env{'course.'.$courseid.
+                              '.default_enrollment_end_date'};
+        my $now = time;
+        foreach my $key (keys(%roleshash)) {
+            if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) {
+                my $group = $1;
+                if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
+                    my $start = $2;
+                    my $end = $1;
+                    if ($start == -1) { next; } # deleted from group
+                    if (($start!=0) && ($start>$now)) { next; }
+                    if (($end!=0) && ($end<$now)) {
+                        if ($access_end && $access_end < $now) {
+                            if ($access_end - $end < 86400) {
+                                push(@usersgroups,$group);
                             }
-                            next;
                         }
-                        push(@usersgroups,$group);
+                        next;
                     }
+                    push(@usersgroups,$group);
                 }
             }
-            @usersgroups = &sort_course_groups($courseid,@usersgroups);
-            $grouplist = join(':',@usersgroups);
-            &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
         }
+        @usersgroups = &sort_course_groups($courseid,@usersgroups);
+        $grouplist = join(':',@usersgroups);
+        &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
     }
     return @usersgroups;
 }
@@ -4931,6 +5045,16 @@ ENDINITMAP
     return '/'.$udom.'/'.$uname;
 }
 
+sub is_course {
+    my ($cdom,$cnum) = @_;
+    my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
+				undef,'.');
+    if (exists($courses{$cdom.'_'.$cnum})) {
+        return 1;
+    }
+    return 0;
+}
+
 # ---------------------------------------------------------- Assign Custom Role
 
 sub assigncustomrole {
@@ -5209,6 +5333,15 @@ sub modify_access_controls {
         #  remove lock
         my @del_lock = ($file_name."\0".'locked_access_records');
         my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
+        my ($file,$group);
+        if (&is_course($domain,$user)) {
+            ($group,$file) = split(/\//,$file_name,2);
+        } else {
+            $file = $file_name;
+        }
+        my $sqlresult =
+            &update_portfolio_table($user,$domain,$file,'portfolio_access',
+                                    $group);
     } else {
         $outcome = "error: could not obtain lockfile\n";  
     }
@@ -7040,14 +7173,7 @@ sub repcopy_userfile {
     } else {
 	my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
 	if ($lwpresp ne 'ok') {
-	    my $ua=new LWP::UserAgent;
-	    my $request=new HTTP::Request('GET',&tokenwrapper($uri));
-	    my $response=$ua->request($request);
-	    if ($response->is_success()) {
-		$info=$response->content;
-	    } else {
-		return -1;
-	    }
+	    return -1;
 	}
 	my @parts = ($cdom,$cnum); 
 	if ($filename =~ m|^(.+)/[^/]+$|) {
@@ -7201,6 +7327,29 @@ sub current_machine_ids {
     return @ids;
 }
 
+sub additional_machine_domains {
+    my @domains;
+    open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");
+    while( my $line = <$fh>) {
+        $line =~ s/\s//g;
+        push(@domains,$line);
+    }
+    return @domains;
+}
+
+sub default_login_domain {
+    my $domain = $perlvar{'lonDefDomain'};
+    my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0];
+    foreach my $posdom (&current_machine_domains(),
+                        &additional_machine_domains()) {
+        if (lc($posdom) eq lc($testdomain)) {
+            $domain=$posdom;
+            last;
+        }
+    }
+    return $domain;
+}
+
 # ------------------------------------------------------------- Declutters URLs
 
 sub declutter {