--- loncom/lonnet/perl/lonnet.pm 2009/05/13 03:28:41 1.976.2.8
+++ loncom/lonnet/perl/lonnet.pm 2009/05/08 12:45:28 1.998
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.976.2.8 2009/05/13 03:28:41 raeburn Exp $
+# $Id: lonnet.pm,v 1.998 2009/05/08 12:45:28 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -73,7 +73,8 @@ package Apache::lonnet;
use strict;
use LWP::UserAgent();
use HTTP::Date;
-# use Date::Parse;
+use Image::Magick;
+
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
$_64bit %env %protocol);
@@ -97,6 +98,8 @@ use LONCAPA::Configuration;
my $readit;
my $max_connection_retries = 10; # Or some such value.
+my $upload_photo_form = 0; #Variable to check when user upload a photo 0=not 1=true
+
require Exporter;
our @ISA = qw (Exporter);
@@ -146,7 +149,8 @@ sub logthis {
my $now=time;
my $local=localtime($now);
if (open(my $fh,">>$execdir/logs/lonnet.log")) {
- print $fh "$local ($$): $message\n";
+ my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.
+ print $fh $logstring;
close($fh);
}
return 1;
@@ -192,6 +196,33 @@ sub get_server_timezone {
}
}
+sub get_server_loncaparev {
+ my ($dom,$lonhost) = @_;
+ if (defined($lonhost)) {
+ if (!defined(&hostname($lonhost))) {
+ undef($lonhost);
+ }
+ }
+ if (!defined($lonhost)) {
+ if (defined(&domain($dom,'primary'))) {
+ $lonhost=&domain($dom,'primary');
+ if ($lonhost eq 'no_host') {
+ undef($lonhost);
+ }
+ }
+ }
+ if (defined($lonhost)) {
+ my $cachetime = 24*3600;
+ my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost);
+ if (defined($cached)) {
+ return $loncaparev;
+ } else {
+ my $loncaparev = &reply('serverloncaparev',$lonhost);
+ return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime);
+ }
+ }
+}
+
# -------------------------------------------------- Non-critical communication
sub subreply {
my ($cmd,$server)=@_;
@@ -535,16 +566,16 @@ sub delenv {
tie(my %disk_env,'GDBM_File',$env{'user.environment'},
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
foreach my $key (keys(%disk_env)) {
- if ($regexp) {
+ if ($regexp) {
if ($key=~/^$delthis/) {
delete($env{$key});
delete($disk_env{$key});
- }
+ }
} else {
if ($key=~/^\Q$delthis\E/) {
- delete($env{$key});
- delete($disk_env{$key});
- }
+ delete($env{$key});
+ delete($disk_env{$key});
+ }
}
}
untie(%disk_env);
@@ -999,27 +1030,34 @@ sub put_dom {
sub retrieve_inst_usertypes {
my ($udom) = @_;
my (%returnhash,@order);
- if (defined(&domain($udom,'primary'))) {
- my $uhome=&domain($udom,'primary');
- my $rep=&reply("inst_usertypes:$udom",$uhome);
- if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
- &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");
- return (\%returnhash,\@order);
- }
- my ($hashitems,$orderitems) = split(/:/,$rep);
- my @pairs=split(/\&/,$hashitems);
- foreach my $item (@pairs) {
- my ($key,$value)=split(/=/,$item,2);
- $key = &unescape($key);
- next if ($key =~ /^error: 2 /);
- $returnhash{$key}=&thaw_unescape($value);
- }
- my @esc_order = split(/\&/,$orderitems);
- foreach my $item (@esc_order) {
- push(@order,&unescape($item));
- }
+ my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
+ if ((ref($domdefs{'inststatustypes'}) eq 'HASH') &&
+ (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
+ %returnhash = %{$domdefs{'inststatustypes'}};
+ @order = @{$domdefs{'inststatusorder'}};
} else {
- &logthis("get_dom failed - no primary domain server for $udom");
+ if (defined(&domain($udom,'primary'))) {
+ my $uhome=&domain($udom,'primary');
+ my $rep=&reply("inst_usertypes:$udom",$uhome);
+ if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
+ &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");
+ return (\%returnhash,\@order);
+ }
+ my ($hashitems,$orderitems) = split(/:/,$rep);
+ my @pairs=split(/\&/,$hashitems);
+ foreach my $item (@pairs) {
+ my ($key,$value)=split(/=/,$item,2);
+ $key = &unescape($key);
+ next if ($key =~ /^error: 2 /);
+ $returnhash{$key}=&thaw_unescape($value);
+ }
+ my @esc_order = split(/\&/,$orderitems);
+ foreach my $item (@esc_order) {
+ push(@order,&unescape($item));
+ }
+ } else {
+ &logthis("get_dom failed - no primary domain server for $udom");
+ }
}
return (\%returnhash,\@order);
}
@@ -1256,7 +1294,8 @@ sub get_domain_defaults {
}
my %domdefaults;
my %domconfig =
- &Apache::lonnet::get_dom('configuration',['defaults','quotas'],$domain);
+ &Apache::lonnet::get_dom('configuration',['defaults','quotas',
+ 'requestcourses','inststatus'],$domain);
if (ref($domconfig{'defaults'}) eq 'HASH') {
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
@@ -1281,6 +1320,16 @@ sub get_domain_defaults {
}
}
}
+ if (ref($domconfig{'requestcourses'}) eq 'HASH') {
+ foreach my $item ('official','unofficial') {
+ $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
+ }
+ }
+ if (ref($domconfig{'inststatus'}) eq 'HASH') {
+ foreach my $item ('inststatustypes','inststatusorder') {
+ $domdefaults{$item} = $domconfig{'inststatus'}{$item};
+ }
+ }
&Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
$cachetime);
return %domdefaults;
@@ -2032,6 +2081,32 @@ sub clean_filename {
$fname=~s/\.(\d+)(?=\.)/_$1/g;
return $fname;
}
+#This Function check if a Image max 400px width and height 500px. If not then scale the image down
+sub resizeImage {
+ my($img_url) = @_;
+ my $ima = Image::Magick->new;
+ $ima->Read($img_url);
+ if($ima->Get('width') > 400)
+ {
+ my $factor = $ima->Get('width')/400;
+ $ima->Scale( width=>400, height=>$ima->Get('height')/$factor );
+ }
+ if($ima->Get('height') > 500)
+ {
+ my $factor = $ima->Get('height')/500;
+ $ima->Scale( width=>$ima->Get('width')/$factor, height=>500);
+ }
+
+ $ima->Write($img_url);
+}
+
+#Wrapper function for userphotoupload
+sub userphotoupload
+{
+ my($formname,$subdir) = @_;
+ $upload_photo_form = 1;
+ return &userfileupload($formname,undef,$subdir);
+}
# --------------- Take an uploaded file and put it into the userfiles directory
# input: $formname - the contents of the file are in $env{"form.$formname"}
@@ -2091,9 +2166,12 @@ sub userfileupload {
close($fh);
return $fullpath.'/'.$fname;
}
-
+ if ($subdir eq 'scantron') {
+ $fname = 'scantron_orig_'.$fname;
+ } else {
# Create the directory if not present
- $fname="$subdir/$fname";
+ $fname="$subdir/$fname";
+ }
if ($coursedoc) {
my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
@@ -2132,6 +2210,7 @@ sub finishuserfileupload {
$thumbwidth,$thumbheight) = @_;
my $path=$docudom.'/'.$docuname.'/';
my $filepath=$perlvar{'lonDocRoot'};
+
my ($fnamepath,$file,$fetchthumb);
$file=$fname;
if ($fname=~m|/|) {
@@ -2146,6 +2225,7 @@ sub finishuserfileupload {
mkdir($filepath,0777);
}
}
+
# Save the file
{
if (!open(FH,'>'.$filepath.'/'.$file)) {
@@ -2159,6 +2239,11 @@ sub finishuserfileupload {
return '/adm/notfound.html';
}
close(FH);
+ if($upload_photo_form==1)
+ {
+ resizeImage($filepath.'/'.$file);
+ $upload_photo_form = 0;
+ }
}
if ($parser eq 'parse') {
my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles,
@@ -2180,7 +2265,7 @@ sub finishuserfileupload {
# Notify homeserver to grep it
#
- my $docuhome=&homeserver($docuname,$docudom);
+ my $docuhome=&homeserver($docuname,$docudom);
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
if ($fetchresult eq 'ok') {
if ($fetchthumb) {
@@ -2312,21 +2397,21 @@ sub add_filetype {
}
sub removeuploadedurl {
- my ($url)=@_;
- my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
+ my ($url)=@_;
+ my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
return &removeuserfile($uname,$udom,$fname);
}
sub removeuserfile {
my ($docuname,$docudom,$fname)=@_;
- my $home=&homeserver($docuname,$docudom);
+ my $home=&homeserver($docuname,$docudom);
my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
- if ($result eq 'ok') {
+ if ($result eq 'ok') {
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 ($file,$group) = (&parse_portfolio_url($url))[3,4];
my $sqlresult =
&update_portfolio_table($docuname,$docudom,$file,
'portfolio_metadata',$group,
@@ -2636,6 +2721,7 @@ sub get_course_adv_roles {
my ($cid,$codes) = @_;
$cid=$env{'request.course.id'} unless (defined($cid));
my %coursehash=&coursedescription($cid);
+ my $crstype = &Apache::loncommon::course_type($cid);
my %nothide=();
foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
if ($user !~ /:/) {
@@ -2661,7 +2747,7 @@ sub get_course_adv_roles {
&Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
$privileged{$domain} = {};
foreach my $server (keys(%dompersonnel)) {
- if (ref($dompersonnel{$server}) eq 'HASH') {
+ if(ref($dompersonnel{$server}) eq 'HASH') {
foreach my $user (keys(%{$dompersonnel{$server}})) {
my ($trole,$uname,$udom) = split(/:/,$user);
$privileged{$udom}{$uname} = 1;
@@ -2669,7 +2755,7 @@ sub get_course_adv_roles {
}
}
}
- if ((exists($privileged{$domain}{$username})) &&
+ if ((exists($privileged{$domain}{$username})) &&
(!$nothide{$username.':'.$domain})) { next; }
if ($role eq 'cr') { next; }
if ($codes) {
@@ -2680,7 +2766,7 @@ sub get_course_adv_roles {
$returnhash{$role}=$username.':'.$domain;
}
} else {
- my $key=&plaintext($role);
+ my $key=&plaintext($role,$crstype);
if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; }
if ($returnhash{$key}) {
$returnhash{$key}.=','.$username.':'.$domain;
@@ -2763,32 +2849,9 @@ sub get_my_roles {
}
}
if ($hidepriv) {
- if ($context eq 'userroles') {
- if ((&privileged($username,$domain)) &&
- (!$nothide{$username.':'.$domain})) {
- next;
- }
- } else {
- unless (ref($privileged{$domain}) eq 'HASH') {
- my %dompersonnel =
- &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
- $privileged{$domain} = {};
- if (keys(%dompersonnel)) {
- foreach my $server (keys(%dompersonnel)) {
- if (ref($dompersonnel{$server}) eq 'HASH') {
- foreach my $user (keys(%{$dompersonnel{$server}})) {
- my ($trole,$uname,$udom) = split(/:/,$user);
- $privileged{$udom}{$uname} = $trole;
- }
- }
- }
- }
- }
- if (exists($privileged{$domain}{$username})) {
- if (!$nothide{$username.':'.$domain}) {
- next;
- }
- }
+ if ((&privileged($username,$domain)) &&
+ (!$nothide{$username.':'.$domain})) {
+ next;
}
}
if ($withsec) {
@@ -3837,6 +3900,67 @@ sub set_userprivs {
return ($author,$adv);
}
+sub role_status {
+ my ($rolekey,$then,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
+ my @pwhere = ();
+ if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
+ (undef,undef,$$role,@pwhere)=split(/\./,$rolekey);
+ unless (!defined($$role) || $$role eq '') {
+ $$where=join('.',@pwhere);
+ $$trolecode=$$role.'.'.$$where;
+ ($$tstart,$$tend)=split(/\./,$env{$rolekey});
+ $$tstatus='is';
+ if ($$tstart && $$tstart>$then) {
+ $$tstatus='future';
+ if ($$tstart<$now) { $$tstatus='will'; }
+ }
+ if ($$tend) {
+ if ($$tend<$then) {
+ $$tstatus='expired';
+ } elsif ($$tend<$now) {
+ $$tstatus='will_not';
+ }
+ }
+ }
+ }
+}
+
+sub check_adhoc_privs {
+ my ($cdom,$cnum,$then,$now,$checkrole) = @_;
+ my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
+ if ($env{$cckey}) {
+ my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
+ &role_status($cckey,$then,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
+ unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {
+ &set_adhoc_privileges($cdom,$cnum,$checkrole);
+ }
+ } else {
+ &set_adhoc_privileges($cdom,$cnum,$checkrole);
+ }
+}
+
+sub set_adhoc_privileges {
+# role can be cc or ca
+ my ($dcdom,$pickedcourse,$role) = @_;
+ my $area = '/'.$dcdom.'/'.$pickedcourse;
+ my $spec = $role.'.'.$area;
+ my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
+ $env{'user.name'});
+ my %ccrole = ();
+ &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);
+ my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);
+ &appenv(\%userroles,[$role,'cm']);
+ &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
+ &appenv( {'request.role' => $spec,
+ 'request.role.domain' => $dcdom,
+ 'request.course.sec' => ''
+ }
+ );
+ my $tadv=0;
+ if (&allowed('adv') eq 'F') { $tadv=1; }
+ &appenv({'request.role.adv' => $tadv});
+}
+
# --------------------------------------------------------------- get interface
sub get {
@@ -3872,11 +3996,11 @@ sub del {
foreach my $item (@$storearr) {
$items.=&escape($item).'&';
}
+
$items=~s/\&$//;
if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
-
return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
}
@@ -4437,13 +4561,23 @@ sub is_portfolio_file {
}
sub usertools_access {
- my ($uname,$udom,$tool,$action) = @_;
- my $access;
- my %tools = (
- aboutme => 1,
- blog => 1,
- portfolio => 1,
- );
+ my ($uname,$udom,$tool,$action,$context) = @_;
+ my ($access,%tools);
+ if ($context eq '') {
+ $context = 'tools';
+ }
+ if ($context eq 'requestcourses') {
+ %tools = (
+ official => 1,
+ unofficial => 1,
+ );
+ } else {
+ %tools = (
+ aboutme => 1,
+ blog => 1,
+ portfolio => 1,
+ );
+ }
return if (!defined($tools{$tool}));
if ((!defined($udom)) || (!defined($uname))) {
@@ -4453,18 +4587,23 @@ sub usertools_access {
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
if ($action ne 'reload') {
- return $env{'environment.availabletools.'.$tool};
+ if ($context eq 'requestcourses') {
+ return $env{'environment.canrequest.'.$tool};
+ } else {
+ return $env{'environment.availabletools.'.$tool};
+ }
}
}
my ($toolstatus,$inststatus);
- if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
- $toolstatus = $env{'environment.tools.'.$tool};
+ if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
+ ($action ne 'reload')) {
+ $toolstatus = $env{'environment.'.$context.'.'.$tool};
$inststatus = $env{'environment.inststatus'};
} else {
- my %userenv = &userenvironment($udom,$uname,'tools.'.$tool);
- $toolstatus = $userenv{'tools.'.$tool};
+ my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool);
+ $toolstatus = $userenv{$context.'.'.$tool};
$inststatus = $userenv{'inststatus'};
}
@@ -4520,7 +4659,11 @@ sub usertools_access {
}
}
} else {
- $access = 1;
+ if ($context eq 'tools') {
+ $access = 1;
+ } else {
+ $access = 0;
+ }
return $access;
}
}
@@ -5645,16 +5788,19 @@ sub devalidate_getgroups_cache {
# ------------------------------------------------------------------ Plain Text
sub plaintext {
- my ($short,$type,$cid) = @_;
+ my ($short,$type,$cid,$forcedefault) = @_;
if ($short =~ /^cr/) {
return (split('/',$short))[-1];
}
if (!defined($cid)) {
$cid = $env{'request.course.id'};
}
- if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) {
- return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short.
- '.plaintext'});
+ if (defined($cid) && ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '')) {
+ unless ($forcedefault) {
+ my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'};
+ &Apache::lonlocal::mt_escape(\$roletext);
+ return &Apache::lonlocal::mt($roletext);
+ }
}
my %rolenames = (
Course => 'std',
@@ -5875,7 +6021,21 @@ sub modifyuser {
if ($email=~/\@/) { $names{'permanentemail'} = $email; }
}
if ($uid) { $names{'id'} = $uid; }
- if (defined($inststatus)) { $names{'inststatus'} = $inststatus; }
+ if (defined($inststatus)) {
+ $names{'inststatus'} = '';
+ my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom);
+ if (ref($usertypes) eq 'HASH') {
+ my @okstatuses;
+ foreach my $item (split(/:/,$inststatus)) {
+ if (defined($usertypes->{$item})) {
+ push(@okstatuses,$item);
+ }
+ }
+ if (@okstatuses) {
+ $names{'inststatus'} = join(':', map { &escape($_); } @okstatuses);
+ }
+ }
+ }
my $reply = &put('environment', \%names, $udom,$uname);
if ($reply ne 'ok') { return 'error: '.$reply; }
my $sqlresult = &update_allusers_table($uname,$udom,\%names);
@@ -5897,7 +6057,7 @@ sub modifyuser {
sub modifystudent {
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
$end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
- $selfenroll,$context)=@_;
+ $selfenroll,$context,$inststatus)=@_;
if (!$cid) {
unless ($cid=$env{'request.course.id'}) {
return 'not_in_class';
@@ -5906,7 +6066,7 @@ sub modifystudent {
# --------------------------------------------------------------- Make the user
my $reply=&modifyuser
($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
- $desiredhome,$email);
+ $desiredhome,$email,$inststatus);
unless ($reply eq 'ok') { return $reply; }
# This will cause &modify_student_enrollment to get the uid from the
# students environment
@@ -8994,6 +9154,31 @@ sub get_dns {
return %iphost;
}
+
+ #
+ # Given a DNS returns the loncapa host name for that DNS
+ #
+ sub host_from_dns {
+ my ($dns) = @_;
+ my @hosts;
+ my $ip;
+
+ if (exists($name_to_ip{$dns})) {
+ $ip = $name_to_ip{$dns};
+ }
+ if (!$ip) {
+ $ip = gethostbyname($dns); # Initial translation to IP is in net order.
+ if (length($ip) == 4) {
+ $ip = &IO::Socket::inet_ntoa($ip);
+ }
+ }
+ if ($ip) {
+ @hosts = get_hosts_from_ip($ip);
+ return $hosts[0];
+ }
+ return undef;
+ }
+
}
BEGIN {
@@ -9276,9 +9461,9 @@ in the user's environment.db and in %env
=item *
X<delenv()>
B<delenv($delthis,$regexp)>: removes all items from the session
-environment file that begin with $delthis. If the
-optional second arg - $regexp - is true, $delthis is treated as a
-regular expression, otherwise \Q$delthis\E is used.
+environment file that begin with $delthis. If the
+optional second arg - $regexp - is true, $delthis is treated as a
+regular expression, otherwise \Q$delthis\E is used.
The values are also deleted from the current processes %env.
=item * get_env_multiple($name)
@@ -9376,9 +9561,14 @@ and course level
=item *
-plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
-explanation of a user role term
-
+plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash
+(rolesplain.tab); plain text explanation of a user role term.
+$type is Course (default) or Group.
+If $forcedefault evaluates to true, text returned will be default
+text for $type. Otherwise, if this is a course, the text returned
+will be a custom name for the role (if defined in the course's
+environment). If no custom name is defined the default is returned.
+
=item *
get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) :
@@ -9887,8 +10077,15 @@ dirlist($uri) : return directory list ba
spareserver() : find server with least workload from spare.tab
+
+=item *
+
+host_from_dns($dns) : Returns the loncapa hostname corresponding to a DNS name or undef
+if there is no corresponding loncapa host.
+
=back
+
=head2 Apache Request
=over 4