--- loncom/lonnet/perl/lonnet.pm 2007/01/18 21:31:40 1.829 +++ loncom/lonnet/perl/lonnet.pm 2007/02/23 00:23:46 1.835 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.829 2007/01/18 21:31:40 www Exp $ +# $Id: lonnet.pm,v 1.835 2007/02/23 00:23:46 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; } @@ -7035,13 +7085,14 @@ sub setup_random_from_rndseed { } sub latest_receipt_algorithm_id { - return 'receipt2'; + return 'receipt3'; } sub recunique { my $fucourseid=shift; my $unique; - if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') { + if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' || + $env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) { $unique=$env{"course.$fucourseid.internal.encseed"}; } else { $unique=$perlvar{'lonReceipt'}; @@ -7052,7 +7103,8 @@ sub recunique { sub recprefix { my $fucourseid=shift; my $prefix; - if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') { + if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2'|| + $env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) { $prefix=$env{"course.$fucourseid.internal.encpref"}; } else { $prefix=$perlvar{'lonHostID'}; @@ -7062,15 +7114,23 @@ sub recprefix { sub ireceipt { my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_; + + my $return =&recprefix($fucourseid).'-'; + + if ($env{"course.$fucourseid.receiptalg"} eq 'receipt3' || + $env{'request.state'} eq 'construct') { + $return .= (&digest("$funame,$fudom,$fucourseid,$fusymb,$part")%10000); + return $return; + } + my $cuname=unpack("%32C*",$funame); my $cudom=unpack("%32C*",$fudom); my $cucourseid=unpack("%32C*",$fucourseid); my $cusymb=unpack("%32C*",$fusymb); my $cunique=&recunique($fucourseid); my $cpart=unpack("%32S*",$part); - my $return =&recprefix($fucourseid).'-'; - if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' || - $env{'request.state'} eq 'construct') { + if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') { + #&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom)); $return.= ($cunique%$cuname+ @@ -7919,6 +7979,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