--- loncom/lonnet/perl/lonnet.pm 2007/04/03 00:49:14 1.857
+++ loncom/lonnet/perl/lonnet.pm 2007/04/05 22:04:49 1.866
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.857 2007/04/03 00:49:14 albertel Exp $
+# $Id: lonnet.pm,v 1.866 2007/04/05 22:04:49 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -734,16 +734,32 @@ sub idput {
# ------------------------------------------- get items from domain db files
sub get_dom {
- my ($namespace,$storearr,$udom)=@_;
+ my ($namespace,$storearr,$udom,$uhome)=@_;
my $items='';
foreach my $item (@$storearr) {
$items.=&escape($item).'&';
}
$items=~s/\&$//;
- if (!$udom) { $udom=$env{'user.domain'}; }
- if (defined(&domain($udom,'primary'))) {
- my $uhome=&domain($udom,'primary');
+ if (!$udom) {
+ $udom=$env{'user.domain'};
+ if (defined(&domain($udom,'primary'))) {
+ $uhome=&domain($udom,'primary');
+ } else {
+ $uhome eq '';
+ }
+ } else {
+ if (!$uhome) {
+ if (defined(&domain($udom,'primary'))) {
+ $uhome=&domain($udom,'primary');
+ }
+ }
+ }
+ if ($udom && $uhome && ($uhome ne 'no_host')) {
my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
+ my %returnhash;
+ if ($rep =~ /^error: 2 /) {
+ return %returnhash;
+ }
my @pairs=split(/\&/,$rep);
if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
return @pairs;
@@ -756,17 +772,29 @@ sub get_dom {
}
return %returnhash;
} else {
- &logthis("get_dom failed - no primary domain server for $udom");
+ &logthis("get_dom failed - no homeserver and/or domain");
}
}
# -------------------------------------------- put items in domain db files
sub put_dom {
- my ($namespace,$storehash,$udom)=@_;
- if (!$udom) { $udom=$env{'user.domain'}; }
- if (defined(&domain($udom,'primary'))) {
- my $uhome=&domain($udom,'primary');
+ my ($namespace,$storehash,$udom,$uhome)=@_;
+ if (!$udom) {
+ $udom=$env{'user.domain'};
+ if (defined(&domain($udom,'primary'))) {
+ $uhome=&domain($udom,'primary');
+ } else {
+ $uhome eq '';
+ }
+ } else {
+ if (!$uhome) {
+ if (defined(&domain($udom,'primary'))) {
+ $uhome=&domain($udom,'primary');
+ }
+ }
+ }
+ if ($udom && $uhome && ($uhome ne 'no_host')) {
my $items='';
foreach my $item (keys(%$storehash)) {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
@@ -774,7 +802,7 @@ sub put_dom {
$items=~s/\&$//;
return &reply("putdom:$udom:$namespace:$items",$uhome);
} else {
- &logthis("put_dom failed - no primary domain server for $udom");
+ &logthis("put_dom failed - no homeserver and/or domain");
}
}
@@ -1516,14 +1544,21 @@ sub clean_filename {
# $coursedoc - if true up to the current course
# if false
# $subdir - directory in userfile to store the file into
-# $parser, $allfiles, $codebase - unknown
-#
+# $parser - instruction to parse file for objects ($parser = parse)
+# $allfiles - reference to hash for embedded objects
+# $codebase - reference to hash for codebase of java objects
+# $desuname - username for permanent storage of uploaded file
+# $dsetudom - domain for permanaent storage of uploaded file
+# $thumbwidth - width (pixels) of thumbnail to make for uploaded image
+# $thumbheight - height (pixels) of thumbnail to make for uploaded image
+#
# output: url of file in userspace, or error: <message>
# or /adm/notfound.html if failure to upload occurse
sub userfileupload {
- my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_;
+ my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,
+ $destudom,$thumbwidth,$thumbheight)=@_;
if (!defined($subdir)) { $subdir='unknown'; }
my $fname=$env{'form.'.$formname.'.filename'};
$fname=&clean_filename($fname);
@@ -1570,7 +1605,7 @@ sub userfileupload {
if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
return &finishuserfileupload($docuname,$docudom,
$formname,$fname,$parser,$allfiles,
- $codebase);
+ $codebase,$thumbwidth,$thumbheight);
} else {
$fname=$env{'form.folder'}.'/'.$fname;
return &process_coursefile('uploaddoc',$docuname,$docudom,
@@ -1580,8 +1615,9 @@ sub userfileupload {
} elsif (defined($destuname)) {
my $docuname=$destuname;
my $docudom=$destudom;
- return &finishuserfileupload($docuname,$docudom,$formname,
- $fname,$parser,$allfiles,$codebase);
+ return &finishuserfileupload($docuname,$docudom,$formname,$fname,
+ $parser,$allfiles,$codebase,
+ $thumbwidth,$thumbheight);
} else {
my $docuname=$env{'user.name'};
@@ -1590,16 +1626,18 @@ sub userfileupload {
$docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
$docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
}
- return &finishuserfileupload($docuname,$docudom,$formname,
- $fname,$parser,$allfiles,$codebase);
+ return &finishuserfileupload($docuname,$docudom,$formname,$fname,
+ $parser,$allfiles,$codebase,
+ $thumbwidth,$thumbheight);
}
}
sub finishuserfileupload {
- my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_;
+ my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase,
+ $thumbwidth,$thumbheight) = @_;
my $path=$docudom.'/'.$docuname.'/';
my $filepath=$perlvar{'lonDocRoot'};
- my ($fnamepath,$file);
+ my ($fnamepath,$file,$fetchthumb);
$file=$fname;
if ($fname=~m|/|) {
($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|);
@@ -1635,11 +1673,28 @@ sub finishuserfileupload {
' for embedded media: '.$parse_result);
}
}
+ if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
+ my $input = $filepath.'/'.$file;
+ my $output = $filepath.'/'.'tn-'.$file;
+ my $thumbsize = $thumbwidth.'x'.$thumbheight;
+ system("convert -sample $thumbsize $input $output");
+ if (-e $filepath.'/'.'tn-'.$file) {
+ $fetchthumb = 1;
+ }
+ }
+
# Notify homeserver to grep it
#
my $docuhome=&homeserver($docuname,$docudom);
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
if ($fetchresult eq 'ok') {
+ if ($fetchthumb) {
+ my $thumbresult= &reply('fetchuserfile:'.$path.'tn-'.$file,$docuhome);
+ if ($thumbresult ne 'ok') {
+ &logthis('Failed to transfer '.$path.'tn-'.$file.' to host '.
+ $docuhome.': '.$thumbresult);
+ }
+ }
#
# Return the URL to it
return '/uploaded/'.$path.$file;
@@ -1647,7 +1702,7 @@ sub finishuserfileupload {
&logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
': '.$fetchresult);
return '/adm/notfound.html';
- }
+ }
}
sub extract_embedded_items {
@@ -2069,11 +2124,16 @@ sub get_course_adv_roles {
}
sub get_my_roles {
- my ($uname,$udom,$types,$roles,$roledoms)=@_;
+ my ($uname,$udom,$context,$types,$roles,$roledoms)=@_;
unless (defined($uname)) { $uname=$env{'user.name'}; }
unless (defined($udom)) { $udom=$env{'user.domain'}; }
- my %dumphash=
+ my %dumphash;
+ if ($context eq 'userroles') {
+ %dumphash = &dump('roles',$udom,$uname);
+ } else {
+ %dumphash=
&dump('nohist_userroles',$udom,$uname);
+ }
my %returnhash=();
my $now=time;
foreach my $entry (keys(%dumphash)) {
@@ -3530,9 +3590,16 @@ sub get_portfolio_access {
}
if (@users > 0) {
foreach my $userkey (@users) {
- if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {
- return 'ok';
- }
+ 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';
+ }
+ }
+ }
+ }
}
}
my %roleshash;
@@ -4349,6 +4416,12 @@ sub courselog_query {
}
sub userlog_query {
+#
+# possible filters:
+# action: log check role
+# start: timestamp
+# end: timestamp
+#
my ($uname,$udom,%filters)=@_;
return &log_query($uname,$udom,'userlog',%filters);
}
@@ -6917,7 +6990,6 @@ sub getCODE {
sub rndseed {
my ($symb,$courseid,$domain,$username)=@_;
-
my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
if (!$symb) {
unless ($symb=$wsymb) { return time; }
@@ -7588,15 +7660,6 @@ sub goodbye {
&logthis("Shutting down");
}
-BEGIN {
-
-# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
- unless ($readit) {
-{
- my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
- %perlvar = (%perlvar,%{$configvars});
-}
-
sub get_dns {
my ($url,$func) = @_;
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
@@ -7631,10 +7694,14 @@ sub get_dns {
$this_domain{$field} = shift(@elements);
}
$domain{$name} = \%this_domain;
- &logthis("Domain.tab: $name ".$domain{$name}{'description'} );
}
}
-
+
+ sub reset_domain_info {
+ undef($loaded);
+ undef(%domain);
+ }
+
sub load_domain_tab {
&get_dns('/adm/dns/domain',\&parse_domain_tab);
my $fh;
@@ -7680,9 +7747,17 @@ sub get_dns {
$hostdom{$id}=$domain;
if ($role eq 'library') { $libserv{$id}=$name; }
}
- &logthis("Hosts.tab: $name ".$id );
}
}
+
+ sub reset_hosts_info {
+ &reset_domain_info();
+ &reset_hosts_ip_info();
+ undef(%hostname);
+ undef(%hostdom);
+ undef(%libserv);
+ undef($loaded);
+ }
sub load_hosts_tab {
&get_dns('/adm/dns/hosts',\&parse_hosts_tab);
@@ -7693,9 +7768,6 @@ sub get_dns {
$loaded=1;
}
- # FIXME: dev server don't want this, production servers _do_ want this
- #&get_iphost();
-
sub hostname {
&load_hosts_tab() if (!$loaded);
@@ -7772,6 +7844,12 @@ sub get_dns {
}
return;
}
+
+ sub reset_hosts_ip_info {
+ undef(%iphost);
+ undef(%name_to_ip);
+ undef(%lonid_to_ip);
+ }
sub get_host_ip {
my ($lonid) = @_;
@@ -7791,7 +7869,7 @@ sub get_dns {
if (%iphost) { return %iphost; }
my %hostname = &all_hostnames();
foreach my $id (keys(%hostname)) {
- my $name=$hostname{$id};
+ my $name=&hostname($id);
my $ip;
if (!exists($name_to_ip{$name})) {
$ip = gethostbyname($name);
@@ -7811,6 +7889,16 @@ sub get_dns {
}
}
+BEGIN {
+
+# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
+ unless ($readit) {
+{
+ my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
+ %perlvar = (%perlvar,%{$configvars});
+}
+
+
# ------------------------------------------------------ Read spare server file
{
open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");
@@ -8142,6 +8230,16 @@ X<userenvironment()>
B<userenvironment($udom,$uname,@what)>: gets the values of the keys
passed in @what from the requested user's environment, returns a hash
+=item *
+X<userlog_query()>
+B<userlog_query($uname,$udom,%filters)>: retrieves data from a user's
+activity.log file. %filters defines filters applied when parsing the
+log file. These can be start or end timestamps, or the type of action
+- log to look for Login or Logout events, check for Checkin or
+Checkout, role for role selection. The response is in the form
+timestamp1:hostid1:event1×tamp2:hostid2:event2 where events are
+escaped strings of the action recorded in the activity.log file.
+
=back
=head2 User Roles
@@ -8171,16 +8269,18 @@ 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.
+get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) :
+All arguments are optional. Returns a hash of a roles, either for
+co-author/assistant author roles for a user's Construction Space
+(default), or if $context is 'user', roles for the user himself,
+In the hash, keys are set to colon-sparated $uname,$udom,and $role,
+and value is 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 of roles reported. If no array ref is
+provided for types, will default to return only active roles.
=back
@@ -8605,12 +8705,15 @@ critical subroutine
=item *
-get_dom($namespace,$storearr,$udomain) : returns hash with keys from array
-reference filled in from namespace found in domain level on primary domain server ($udomain is optional)
+get_dom($namespace,$storearr,$udom,$uhome) : returns hash with keys from
+array reference filled in from namespace found in domain level on either
+specified domain server ($uhome) or primary domain server ($udom and $uhome are optional).
=item *
-put_dom($namespace,$storehash,$udomain) : stores hash in namespace at domain level on primary domain server ($udomain is optional)
+put_dom($namespace,$storehash,$udom,$uhome) : stores hash in namespace at
+domain level either on specified domain server ($uhome) or primary domain
+server ($udom and $uhome are optional)
=back