--- loncom/lonnet/perl/lonnet.pm	2007/04/24 19:38:15	1.824.2.4
+++ loncom/lonnet/perl/lonnet.pm	2007/02/18 01:52:20	1.834
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.824.2.4 2007/04/24 19:38:15 albertel Exp $
+# $Id: lonnet.pm,v 1.834 2007/02/18 01:52:20 albertel Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -990,16 +990,10 @@ 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=&make_key($name,$id);
+    $id=&escape($name.':'.$id);
     $memcache->delete($id);
     delete($remembered{$id});
     delete($accessed{$id});
@@ -1007,7 +1001,7 @@ sub devalidate_cache_new {
 
 sub is_cached_new {
     my ($name,$id,$debug) = @_;
-    $id=&make_key($name,$id);
+    $id=&escape($name.':'.$id);
     if (exists($remembered{$id})) {
 	if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
 	$accessed{$id}=[&gettimeofday()];
@@ -1030,7 +1024,7 @@ sub is_cached_new {
 
 sub do_cache_new {
     my ($name,$id,$value,$time,$debug) = @_;
-    $id=&make_key($name,$id);
+    $id=&escape($name.':'.$id);
     my $setvalue=$value;
     if (!defined($setvalue)) {
 	$setvalue='__undef__';
@@ -1208,6 +1202,7 @@ sub repcopy {
     }
     $filename=~s/[\n\r]//g;
     my $transname="$filename.in.transfer";
+# FIXME: this should flock
     if ((-e $filename) || (-e $transname)) { return 'ok'; }
     my $remoteurl=subscribe($filename);
     if ($remoteurl =~ /^con_lost by/) {
@@ -1456,15 +1451,17 @@ sub store_edited_file {
 }
 
 sub clean_filename {
-    my ($fname)=@_;
+    my ($fname,$args)=@_;
 # Replace Windows backslashes by forward slashes
     $fname=~s/\\/\//g;
-# Get rid of everything but the actual filename
-    $fname=~s/^.*\/([^\/]+)$/$1/;
+    if (!$args->{'keep_path'}) {
+        # Get rid of everything but the actual filename
+	$fname=~s/^.*\/([^\/]+)$/$1/;
+    }
 # Replace spaces by underscores
     $fname=~s/\s+/\_/g;
 # Replace all other weird characters by nothing
-    $fname=~s/[^\w\.\-]//g;
+    $fname=~s{[^/\w\.\-]}{}g;
 # Replace all .\d. sequences with _\d. so they no longer look like version
 # numbers
     $fname=~s/\.(\d+)(?=\.)/_$1/g;
@@ -2030,7 +2027,7 @@ sub get_course_adv_roles {
 }
 
 sub get_my_roles {
-    my ($uname,$udom)=@_;
+    my ($uname,$udom,$types,$roles,$roledoms)=@_;
     unless (defined($uname)) { $uname=$env{'user.name'}; }
     unless (defined($udom)) { $udom=$env{'user.domain'}; }
     my %dumphash=
@@ -2040,11 +2037,35 @@ sub get_my_roles {
     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 $status = 'active';
+        if (($tend) && ($tend<$now)) {
+            $status = 'previous';
+        } 
+        if (($tstart) && ($now<$tstart)) {
+            $status = 'future';
+        }
+        if (ref($types) eq 'ARRAY') {
+            if (!grep(/^\Q$status\E$/,@{$types})) {
+                next;
+            } 
+        } else {
+            if ($status ne 'active') {
+                next;
+            }
+        }
         my ($role,$username,$domain,$section)=split(/\:/,$entry);
+        if (ref($roledoms) eq 'ARRAY') {
+            if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
+                next;
+            }
+        }
+        if (ref($roles) eq 'ARRAY') {
+            if (!grep(/^\Q$role\E$/,@{$roles})) {
+                next;
+            }
+        } 
 	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
-     }
+    }
     return %returnhash;
 }
 
@@ -3461,16 +3482,9 @@ sub get_portfolio_access {
             }
             if (@users > 0) {
                 foreach my $userkey (@users) {
-                    if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') {
-                        foreach my $item (@{$access_hash->{$userkey}{'users'}}) {
-                            if (ref($item) eq 'HASH') {
-                                if (($item->{'uname'} eq $env{'user.name'}) &&
-                                    ($item->{'udom'} eq $env{'user.domain'})) {
-                                    return 'ok';
-                                }
-                            }
-                        }
-                    } 
+                    if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {
+                        return 'ok';
+                    }
                 }
             }
             my %roleshash;
@@ -5120,9 +5134,7 @@ sub is_locked {
 
 sub declutter_portfile {
     my ($file) = @_;
-    &logthis("got $file");
-    $file =~ s-^(/portfolio/|portfolio/)-/-;
-    &logthis("ret $file");
+    $file =~ s{^(/portfolio/|portfolio/)}{/};
     return $file;
 }
 
@@ -5355,6 +5367,53 @@ sub modify_access_controls {
     return ($outcome,$deloutcome,\%new_values,\%translation);
 }
 
+sub make_public_indefinitely {
+    my ($requrl) = @_;
+    my $now = time;
+    my $action = 'activate';
+    my $aclnum = 0;
+    if (&is_portfolio_url($requrl)) {
+        my (undef,$udom,$unum,$file_name,$group) =
+            &parse_portfolio_url($requrl);
+        my $current_perms = &get_portfile_permissions($udom,$unum);
+        my %access_controls = &get_access_controls($current_perms,
+                                                   $group,$file_name);
+        foreach my $key (keys(%{$access_controls{$file_name}})) {
+            my ($num,$scope,$end,$start) = 
+                ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
+            if ($scope eq 'public') {
+                if ($start <= $now && $end == 0) {
+                    $action = 'none';
+                } else {
+                    $action = 'update';
+                    $aclnum = $num;
+                }
+                last;
+            }
+        }
+        if ($action eq 'none') {
+             return 'ok';
+        } else {
+            my %changes;
+            my $newend = 0;
+            my $newstart = $now;
+            my $newkey = $aclnum.':public_'.$newend.'_'.$newstart;
+            $changes{$action}{$newkey} = {
+                type => 'public',
+                time => {
+                    start => $newstart,
+                    end   => $newend,
+                },
+            };
+            my ($outcome,$deloutcome,$new_values,$translation) =
+                &modify_access_controls($file_name,\%changes,$udom,$unum);
+            return $outcome;
+        }
+    } else {
+        return 'invalid';
+    }
+}
+
 #------------------------------------------------------Get Marked as Read Only
 
 sub get_marked_as_readonly {
@@ -7150,53 +7209,59 @@ sub repcopy_userfile {
     if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; }
     my ($cdom,$cnum,$filename) = 
 	($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
-    my ($info,$rtncode);
     my $uri="/uploaded/$cdom/$cnum/$filename";
     if (-e "$file") {
+# we already have a local copy, check it out
 	my @fileinfo = stat($file);
+	my $rtncode;
+	my $info;
 	my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
 	if ($lwpresp ne 'ok') {
+# there is no such file anymore, even though we had a local copy
 	    if ($rtncode eq '404') {
 		unlink($file);
 	    }
-	    #my $ua=new LWP::UserAgent;
-	    #my $request=new HTTP::Request('GET',&tokenwrapper($uri));
-	    #my $response=$ua->request($request);
-	    #if ($response->is_success()) {
-	#	return $response->content;
-	#    } else {
-	#	return -1;
-	#    }
 	    return -1;
 	}
 	if ($info < $fileinfo[9]) {
+# nice, the file we have is up-to-date, just say okay
 	    return 'ok';
+	} else {
+# the file is outdated, get rid of it
+	    unlink($file);
 	}
-	$info = '';
-	$lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
-	if ($lwpresp ne 'ok') {
-	    return -1;
-	}
-    } else {
-	my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
-	if ($lwpresp ne 'ok') {
-	    return -1;
-	}
-	my @parts = ($cdom,$cnum); 
-	if ($filename =~ m|^(.+)/[^/]+$|) {
-	    push @parts, split(/\//,$1);
-	}
-	my $path = $perlvar{'lonDocRoot'}.'/userfiles';
-	foreach my $part (@parts) {
-	    $path .= '/'.$part;
-	    if (!-e $path) {
-		mkdir($path,0770);
-	    }
+    }
+# one way or the other, at this point, we don't have the file
+# construct the correct path for the file
+    my @parts = ($cdom,$cnum); 
+    if ($filename =~ m|^(.+)/[^/]+$|) {
+	push @parts, split(/\//,$1);
+    }
+    my $path = $perlvar{'lonDocRoot'}.'/userfiles';
+    foreach my $part (@parts) {
+	$path .= '/'.$part;
+	if (!-e $path) {
+	    mkdir($path,0770);
 	}
     }
-    open(FILE,">$file");
-    print FILE $info;
-    close(FILE);
+# now the path exists for sure
+# get a user agent
+    my $ua=new LWP::UserAgent;
+    my $transferfile=$file.'.in.transfer';
+# FIXME: this should flock
+    if (-e $transferfile) { return 'ok'; }
+    my $request;
+    $uri=~s/^\///;
+    $request=new HTTP::Request('GET','http://'.$hostname{&homeserver($cnum,$cdom)}.'/raw/'.$uri);
+    my $response=$ua->request($request,$transferfile);
+# did it work?
+    if ($response->is_error()) {
+	unlink($transferfile);
+	&logthis("Userfile repcopy failed for $uri");
+	return -1;
+    }
+# worked, rename the transfer file
+    rename($transferfile,$file);
     return 'ok';
 }
 
@@ -7218,6 +7283,10 @@ sub tokenwrapper {
     }
 }
 
+# call with reqtype HEAD: get last modification time
+# call with reqtype GET: get the file contents
+# Do not call this with reqtype GET for large files! It loads everything into memory
+#
 sub getuploaded {
     my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
     $uri=~s/^\///;
@@ -7529,7 +7598,7 @@ sub get_iphost {
 	if (!exists($name_to_ip{$name})) {
 	    $ip = gethostbyname($name);
 	    if (!$ip || length($ip) ne 4) {
-		&logthis("Skipping host $id name $name no IP found\n");
+		&logthis("Skipping host $id name $name no IP found");
 		next;
 	    }
 	    $ip=inet_ntoa($ip);
@@ -7900,6 +7969,19 @@ and course level
 plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
 explanation of a user role term
 
+=item *
+
+get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are
+optional.  Returns a hash of a user's roles, with keys set to
+colon-sparated $uname,$udom,and $role, and value set to
+colon-separated start and end times for the role. If no username and
+domain are specified, will default to current user/domain. Types,
+roles, and roledoms are references to arrays, of role statuses
+(active, future or previous), roles (e.g., cc,in, st etc.) and domains
+of the roles which can be used to restrict the list if roles
+reported. If no array ref is provided for types, will default to
+return only active roles.
+
 =back
 
 =head2 User Modification