--- loncom/lonnet/perl/lonnet.pm	2007/01/18 21:02:06	1.828
+++ loncom/lonnet/perl/lonnet.pm	2007/02/18 01:51:20	1.833
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.828 2007/01/18 21:02:06 www Exp $
+# $Id: lonnet.pm,v 1.833 2007/02/18 01:51:20 albertel Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -367,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 {
@@ -381,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;
 	}
@@ -399,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});
@@ -1425,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;
@@ -1999,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=
@@ -2009,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;
 }
 
@@ -5082,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;
 }
 
@@ -7202,13 +7252,7 @@ sub repcopy_userfile {
     if (-e $transferfile) { return 'ok'; }
     my $request;
     $uri=~s/^\///;
-    if (&homeserver($cnum,$cdom) eq $perlvar{'lonHostID'}) {
-# if this is my own server, get it via tokenwrapper
-        $request=new HTTP::Request('GET',&tokenwrapper('/'.$uri));
-    } else {
-# get it from another server, raw request
-	$request=new HTTP::Request('GET','http://'.$hostname{&homeserver($cnum,$cdom)}.'/raw/'.$uri);
-    }
+    $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()) {
@@ -7925,6 +7969,9 @@ 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