--- loncom/lonnet/perl/lonnet.pm 2009/05/15 20:31:04 1.976.2.9
+++ loncom/lonnet/perl/lonnet.pm 2009/03/01 01:12:23 1.988
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.976.2.9 2009/05/15 20:31:04 raeburn Exp $
+# $Id: lonnet.pm,v 1.988 2009/03/01 01:12:23 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -73,6 +73,9 @@ package Apache::lonnet;
use strict;
use LWP::UserAgent();
use HTTP::Date;
+use Image::Magick;
+use IO::Socket;
+
# use Date::Parse;
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
$_64bit %env %protocol);
@@ -97,6 +100,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 +151,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;
@@ -535,16 +541,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);
@@ -1281,6 +1287,11 @@ sub get_domain_defaults {
}
}
}
+ if (ref($domconfig{'requestcourses'}) eq 'HASH') {
+ foreach my $item ('official','unofficial') {
+ $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
+ }
+ }
&Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
$cachetime);
return %domdefaults;
@@ -2032,6 +2043,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"}
@@ -2132,6 +2169,7 @@ sub finishuserfileupload {
$thumbwidth,$thumbheight) = @_;
my $path=$docudom.'/'.$docuname.'/';
my $filepath=$perlvar{'lonDocRoot'};
+
my ($fnamepath,$file,$fetchthumb);
$file=$fname;
if ($fname=~m|/|) {
@@ -2146,6 +2184,7 @@ sub finishuserfileupload {
mkdir($filepath,0777);
}
}
+
# Save the file
{
if (!open(FH,'>'.$filepath.'/'.$file)) {
@@ -2159,6 +2198,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 +2224,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 +2356,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,
@@ -2624,9 +2668,6 @@ sub courserolelog {
$storehash{'section'} = $sec;
}
&instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);
- if (($trole ne 'st') || ($sec ne '')) {
- &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);
- }
}
}
return;
@@ -2636,6 +2677,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 !~ /:/) {
@@ -2648,7 +2690,6 @@ sub get_course_adv_roles {
my %dumphash=
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
my $now=time;
- my %privileged;
foreach my $entry (keys %dumphash) {
my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
if (($tstart) && ($tstart<0)) { next; }
@@ -2656,21 +2697,8 @@ sub get_course_adv_roles {
if (($tstart) && ($now<$tstart)) { next; }
my ($role,$username,$domain,$section)=split(/\:/,$entry);
if ($username eq '' || $domain eq '') { next; }
- unless (ref($privileged{$domain}) eq 'HASH') {
- my %dompersonnel =
- &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
- $privileged{$domain} = {};
- 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} = 1;
- }
- }
- }
- }
- if ((exists($privileged{$domain}{$username})) &&
- (!$nothide{$username.':'.$domain})) { next; }
+ if ((&privileged($username,$domain)) &&
+ (!$nothide{$username.':'.$domain})) { next; }
if ($role eq 'cr') { next; }
if ($codes) {
if ($section) { $role .= ':'.$section; }
@@ -2680,7 +2708,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;
@@ -2715,7 +2743,6 @@ sub get_my_roles {
}
my %returnhash=();
my $now=time;
- my %privileged;
foreach my $entry (keys(%dumphash)) {
my ($role,$tend,$tstart);
if ($context eq 'userroles') {
@@ -2764,32 +2791,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) {
@@ -3873,11 +3877,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);
}
@@ -4438,13 +4442,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))) {
@@ -4454,18 +4468,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'};
}
@@ -4521,7 +4540,11 @@ sub usertools_access {
}
}
} else {
- $access = 1;
+ if ($context eq 'tools') {
+ $access = 1;
+ } else {
+ $access = 0;
+ }
return $access;
}
}
@@ -5646,16 +5669,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',
@@ -8997,6 +9023,23 @@ sub get_dns {
}
}
+#
+# Given a DNS returns the loncapa host name for that DNS
+#
+sub host_from_dns {
+ my ($dns) = @_;
+ my @hosts;
+ my $ip;
+
+ $ip = gethostbyname($dns); # Initial translation to IP is in net order.
+ if (length($ip) == 4) {
+ $ip = &IO::Socket::inet_ntoa($ip);
+ @hosts = get_hosts_from_ip($ip);
+ return $hosts[0];
+ }
+ return undef;
+}
+
BEGIN {
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
@@ -9277,9 +9320,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)
@@ -9377,9 +9420,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) :
@@ -9888,8 +9936,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