version 1.976.2.4, 2008/12/31 18:26:53
|
version 1.986, 2009/02/10 11:15:16
|
Line 73 package Apache::lonnet;
|
Line 73 package Apache::lonnet;
|
use strict; |
use strict; |
use LWP::UserAgent(); |
use LWP::UserAgent(); |
use HTTP::Date; |
use HTTP::Date; |
|
use Image::Magick; |
|
use IO::Socket; |
|
|
# use Date::Parse; |
# use Date::Parse; |
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir |
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir |
$_64bit %env %protocol); |
$_64bit %env %protocol); |
Line 97 use LONCAPA::Configuration;
|
Line 100 use LONCAPA::Configuration;
|
my $readit; |
my $readit; |
my $max_connection_retries = 10; # Or some such value. |
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; |
require Exporter; |
|
|
our @ISA = qw (Exporter); |
our @ISA = qw (Exporter); |
Line 146 sub logthis {
|
Line 151 sub logthis {
|
my $now=time; |
my $now=time; |
my $local=localtime($now); |
my $local=localtime($now); |
if (open(my $fh,">>$execdir/logs/lonnet.log")) { |
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); |
close($fh); |
} |
} |
return 1; |
return 1; |
Line 177 sub create_connection {
|
Line 183 sub create_connection {
|
return 0; |
return 0; |
} |
} |
|
|
|
sub get_server_timezone { |
|
my ($cnum,$cdom) = @_; |
|
my $home=&homeserver($cnum,$cdom); |
|
if ($home ne 'no_host') { |
|
my $cachetime = 24*3600; |
|
my ($timezone,$cached)=&is_cached_new('servertimezone',$home); |
|
if (defined($cached)) { |
|
return $timezone; |
|
} else { |
|
my $timezone = &reply('servertimezone',$home); |
|
return &do_cache_new('servertimezone',$home,$timezone,$cachetime); |
|
} |
|
} |
|
} |
|
|
# -------------------------------------------------- Non-critical communication |
# -------------------------------------------------- Non-critical communication |
sub subreply { |
sub subreply { |
Line 1227 sub inst_userrules {
|
Line 1247 sub inst_userrules {
|
sub get_domain_defaults { |
sub get_domain_defaults { |
my ($domain) = @_; |
my ($domain) = @_; |
my $cachetime = 60*60*24; |
my $cachetime = 60*60*24; |
my ($defauthtype,$defautharg,$deflang,%deftools); |
|
my ($result,$cached)=&is_cached_new('domdefaults',$domain); |
my ($result,$cached)=&is_cached_new('domdefaults',$domain); |
if (defined($cached)) { |
if (defined($cached)) { |
if (ref($result) eq 'HASH') { |
if (ref($result) eq 'HASH') { |
Line 1241 sub get_domain_defaults {
|
Line 1260 sub get_domain_defaults {
|
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; |
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; |
$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; |
$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; |
$domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'}; |
$domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'}; |
|
$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; |
|
$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; |
} else { |
} else { |
$domdefaults{'lang_def'} = &domain($domain,'lang_def'); |
$domdefaults{'lang_def'} = &domain($domain,'lang_def'); |
$domdefaults{'auth_def'} = &domain($domain,'auth_def'); |
$domdefaults{'auth_def'} = &domain($domain,'auth_def'); |
Line 1259 sub get_domain_defaults {
|
Line 1280 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, |
&Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, |
$cachetime); |
$cachetime); |
return %domdefaults; |
return %domdefaults; |
Line 2010 sub clean_filename {
|
Line 2036 sub clean_filename {
|
$fname=~s/\.(\d+)(?=\.)/_$1/g; |
$fname=~s/\.(\d+)(?=\.)/_$1/g; |
return $fname; |
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 |
# --------------- Take an uploaded file and put it into the userfiles directory |
# input: $formname - the contents of the file are in $env{"form.$formname"} |
# input: $formname - the contents of the file are in $env{"form.$formname"} |
Line 2110 sub finishuserfileupload {
|
Line 2162 sub finishuserfileupload {
|
$thumbwidth,$thumbheight) = @_; |
$thumbwidth,$thumbheight) = @_; |
my $path=$docudom.'/'.$docuname.'/'; |
my $path=$docudom.'/'.$docuname.'/'; |
my $filepath=$perlvar{'lonDocRoot'}; |
my $filepath=$perlvar{'lonDocRoot'}; |
|
|
my ($fnamepath,$file,$fetchthumb); |
my ($fnamepath,$file,$fetchthumb); |
$file=$fname; |
$file=$fname; |
if ($fname=~m|/|) { |
if ($fname=~m|/|) { |
Line 2124 sub finishuserfileupload {
|
Line 2177 sub finishuserfileupload {
|
mkdir($filepath,0777); |
mkdir($filepath,0777); |
} |
} |
} |
} |
|
|
# Save the file |
# Save the file |
{ |
{ |
if (!open(FH,'>'.$filepath.'/'.$file)) { |
if (!open(FH,'>'.$filepath.'/'.$file)) { |
Line 2137 sub finishuserfileupload {
|
Line 2191 sub finishuserfileupload {
|
return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
} |
} |
close(FH); |
close(FH); |
|
if($upload_photo_form==1) |
|
{ |
|
resizeImage($filepath.'/'.$file); |
|
$upload_photo_form = 0; |
|
} |
} |
} |
if ($parser eq 'parse') { |
if ($parser eq 'parse') { |
my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles, |
my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles, |
Line 2158 sub finishuserfileupload {
|
Line 2217 sub finishuserfileupload {
|
|
|
# Notify homeserver to grep it |
# Notify homeserver to grep it |
# |
# |
my $docuhome=&homeserver($docuname,$docudom); |
my $docuhome=&homeserver($docuname,$docudom); |
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); |
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); |
if ($fetchresult eq 'ok') { |
if ($fetchresult eq 'ok') { |
if ($fetchthumb) { |
if ($fetchthumb) { |
Line 2290 sub add_filetype {
|
Line 2349 sub add_filetype {
|
} |
} |
|
|
sub removeuploadedurl { |
sub removeuploadedurl { |
my ($url)=@_; |
my ($url)=@_; |
my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); |
my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); |
return &removeuserfile($uname,$udom,$fname); |
return &removeuserfile($uname,$udom,$fname); |
} |
} |
|
|
sub removeuserfile { |
sub removeuserfile { |
my ($docuname,$docudom,$fname)=@_; |
my ($docuname,$docudom,$fname)=@_; |
my $home=&homeserver($docuname,$docudom); |
my $home=&homeserver($docuname,$docudom); |
my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home); |
my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home); |
if ($result eq 'ok') { |
if ($result eq 'ok') { |
if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) { |
if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) { |
my $metafile = $fname.'.meta'; |
my $metafile = $fname.'.meta'; |
my $metaresult = &removeuserfile($docuname,$docudom,$metafile); |
my $metaresult = &removeuserfile($docuname,$docudom,$metafile); |
my $url = "/uploaded/$docudom/$docuname/$fname"; |
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 = |
my $sqlresult = |
&update_portfolio_table($docuname,$docudom,$file, |
&update_portfolio_table($docuname,$docudom,$file, |
'portfolio_metadata',$group, |
'portfolio_metadata',$group, |
Line 3810 sub del {
|
Line 3869 sub del {
|
foreach my $item (@$storearr) { |
foreach my $item (@$storearr) { |
$items.=&escape($item).'&'; |
$items.=&escape($item).'&'; |
} |
} |
|
|
$items=~s/\&$//; |
$items=~s/\&$//; |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
|
|
return &reply("del:$udomain:$uname:$namespace:$items",$uhome); |
return &reply("del:$udomain:$uname:$namespace:$items",$uhome); |
} |
} |
|
|
Line 4375 sub is_portfolio_file {
|
Line 4434 sub is_portfolio_file {
|
} |
} |
|
|
sub usertools_access { |
sub usertools_access { |
my ($uname,$udom,$tool,$action) = @_; |
my ($uname,$udom,$tool,$action,$context) = @_; |
my $access; |
my ($access,%tools); |
my %tools = ( |
if ($context eq '') { |
aboutme => 1, |
$context = 'tools'; |
blog => 1, |
} |
portfolio => 1, |
if ($context eq 'requestcourses') { |
); |
%tools = ( |
|
official => 1, |
|
unofficial => 1, |
|
); |
|
} else { |
|
%tools = ( |
|
aboutme => 1, |
|
blog => 1, |
|
portfolio => 1, |
|
); |
|
} |
return if (!defined($tools{$tool})); |
return if (!defined($tools{$tool})); |
|
|
if ((!defined($udom)) || (!defined($uname))) { |
if ((!defined($udom)) || (!defined($uname))) { |
Line 4391 sub usertools_access {
|
Line 4460 sub usertools_access {
|
|
|
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
if ($action ne 'reload') { |
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); |
my ($toolstatus,$inststatus); |
|
|
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && |
$toolstatus = $env{'environment.tools.'.$tool}; |
($action ne 'reload')) { |
|
$toolstatus = $env{'environment.'.$context.'.'.$tool}; |
$inststatus = $env{'environment.inststatus'}; |
$inststatus = $env{'environment.inststatus'}; |
} else { |
} else { |
my %userenv = &userenvironment($udom,$uname,'tools.'.$tool); |
my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool); |
$toolstatus = $userenv{'tools.'.$tool}; |
$toolstatus = $userenv{$context.'.'.$tool}; |
$inststatus = $userenv{'inststatus'}; |
$inststatus = $userenv{'inststatus'}; |
} |
} |
|
|
Line 4458 sub usertools_access {
|
Line 4532 sub usertools_access {
|
} |
} |
} |
} |
} else { |
} else { |
$access = 1; |
if ($context eq 'tools') { |
|
$access = 1; |
|
} else { |
|
$access = 0; |
|
} |
return $access; |
return $access; |
} |
} |
} |
} |
Line 8934 sub get_dns {
|
Line 9012 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 { |
BEGIN { |
|
|
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
Line 9823 dirlist($uri) : return directory list ba
|
Line 9918 dirlist($uri) : return directory list ba
|
|
|
spareserver() : find server with least workload from spare.tab |
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 |
=back |
|
|
|
|
=head2 Apache Request |
=head2 Apache Request |
|
|
=over 4 |
=over 4 |