version 1.977, 2008/12/09 11:32:03
|
version 1.986, 2009/02/10 11:15:16
|
Line 74 use strict;
|
Line 74 use strict;
|
use LWP::UserAgent(); |
use LWP::UserAgent(); |
use HTTP::Date; |
use HTTP::Date; |
use Image::Magick; |
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 |
Line 150 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 181 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 525 sub delenv {
|
Line 541 sub delenv {
|
tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
foreach my $key (keys(%disk_env)) { |
foreach my $key (keys(%disk_env)) { |
if ($key=~/^$delthis/) { |
if ($key=~/^\Q$delthis\E/) { |
delete($env{$key}); |
delete($env{$key}); |
delete($disk_env{$key}); |
delete($disk_env{$key}); |
} |
} |
Line 1231 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 1245 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 1263 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 1791 sub ssi_body {
|
Line 1813 sub ssi_body {
|
} |
} |
my $output=''; |
my $output=''; |
my $response; |
my $response; |
if ($filelink=~/^http\:/) { |
if ($filelink=~/^https?\:/) { |
($output,$response)=&externalssi($filelink); |
($output,$response)=&externalssi($filelink); |
} else { |
} else { |
($output,$response)=&ssi($filelink,%form); |
($output,$response)=&ssi($filelink,%form); |
Line 2014 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 |
#Wrapper function for userphotoupload |
sub userphotoupload |
sub userphotoupload |
Line 2122 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 2136 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 2151 sub finishuserfileupload {
|
Line 2193 sub finishuserfileupload {
|
close(FH); |
close(FH); |
if($upload_photo_form==1) |
if($upload_photo_form==1) |
{ |
{ |
my $ima = Image::Magick->new; |
resizeImage($filepath.'/'.$file); |
$ima->Read($filepath.'/'.$file); |
|
if($ima->Get('width') > 300) |
|
{ |
|
my $factor = $ima->Get('width')/300; |
|
$ima->Scale( width=>300, height=>$ima->Get('height')/$factor ); |
|
} |
|
if($ima->Get('height') > 400) |
|
{ |
|
my $factor = $ima->Get('height')/400; |
|
$ima->Scale( width=>$ima->Get('width')/$factor, height=>400); |
|
} |
|
|
|
|
|
$ima->Write($filepath.'/'.$file); |
|
$upload_photo_form = 0; |
$upload_photo_form = 0; |
} |
} |
} |
} |
Line 2189 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 2321 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 3841 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 4406 sub is_portfolio_file {
|
Line 4434 sub is_portfolio_file {
|
} |
} |
|
|
sub usertools_access { |
sub usertools_access { |
my ($uname,$udom,$tool) = @_; |
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 4420 sub usertools_access {
|
Line 4458 sub usertools_access {
|
$uname = $env{'user.name'}; |
$uname = $env{'user.name'}; |
} |
} |
|
|
my $hashid=$uname.':'.$udom; |
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
my ($result,$cached) = &is_cached_new('usertools.'.$tool,$hashid); |
if ($action ne 'reload') { |
if (defined($cached)) { |
if ($context eq 'requestcourses') { |
return $result; |
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 4443 sub usertools_access {
|
Line 4486 sub usertools_access {
|
} else { |
} else { |
$access = 0; |
$access = 0; |
} |
} |
&do_cache_new('usertools.'.$tool,$hashid,$access,600); |
|
return $access; |
return $access; |
} |
} |
|
|
Line 4457 sub usertools_access {
|
Line 4499 sub usertools_access {
|
} else { |
} else { |
$access = 0; |
$access = 0; |
} |
} |
&do_cache_new('usertools.'.$tool,$hashid,$access,600); |
|
return $access; |
return $access; |
} |
} |
} |
} |
Line 4478 sub usertools_access {
|
Line 4519 sub usertools_access {
|
} elsif ($hasnoaccess) { |
} elsif ($hasnoaccess) { |
$access = 0; |
$access = 0; |
} |
} |
&do_cache_new('usertools.'.$tool,$hashid,$access,600); |
|
return $access; |
return $access; |
} |
} |
} else { |
} else { |
Line 4488 sub usertools_access {
|
Line 4528 sub usertools_access {
|
} elsif ($domdef{$tool}{'default'} == 0) { |
} elsif ($domdef{$tool}{'default'} == 0) { |
$access = 0; |
$access = 0; |
} |
} |
&do_cache_new('usertools.'.$tool,$hashid,$access,600); |
|
return $access; |
return $access; |
} |
} |
} |
} |
} else { |
} else { |
$access = 1; |
if ($context eq 'tools') { |
&do_cache_new('usertools.'.$tool,$hashid,$access,600); |
$access = 1; |
|
} else { |
|
$access = 0; |
|
} |
return $access; |
return $access; |
} |
} |
} |
} |
Line 8337 sub repcopy_userfile {
|
Line 8379 sub repcopy_userfile {
|
if (-e $transferfile) { return 'ok'; } |
if (-e $transferfile) { return 'ok'; } |
my $request; |
my $request; |
$uri=~s/^\///; |
$uri=~s/^\///; |
$request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri); |
my $homeserver = &homeserver($cnum,$cdom); |
|
my $protocol = $protocol{$homeserver}; |
|
$protocol = 'http' if ($protocol ne 'https'); |
|
$request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri); |
my $response=$ua->request($request,$transferfile); |
my $response=$ua->request($request,$transferfile); |
# did it work? |
# did it work? |
if ($response->is_error()) { |
if ($response->is_error()) { |
Line 8352 sub repcopy_userfile {
|
Line 8397 sub repcopy_userfile {
|
|
|
sub tokenwrapper { |
sub tokenwrapper { |
my $uri=shift; |
my $uri=shift; |
$uri=~s|^http\://([^/]+)||; |
$uri=~s|^https?\://([^/]+)||; |
$uri=~s|^/||; |
$uri=~s|^/||; |
$env{'user.environment'}=~/\/([^\/]+)\.id/; |
$env{'user.environment'}=~/\/([^\/]+)\.id/; |
my $token=$1; |
my $token=$1; |
Line 8360 sub tokenwrapper {
|
Line 8405 sub tokenwrapper {
|
if ($udom && $uname && $file) { |
if ($udom && $uname && $file) { |
$file=~s|(\?\.*)*$||; |
$file=~s|(\?\.*)*$||; |
&appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}}); |
&appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}}); |
return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri. |
my $homeserver = &homeserver($uname,$udom); |
|
my $protocol = $protocol{$homeserver}; |
|
$protocol = 'http' if ($protocol ne 'https'); |
|
return $protocol.'://'.&hostname($homeserver).'/'.$uri. |
(($uri=~/\?/)?'&':'?').'token='.$token. |
(($uri=~/\?/)?'&':'?').'token='.$token. |
'&tokenissued='.$perlvar{'lonHostID'}; |
'&tokenissued='.$perlvar{'lonHostID'}; |
} else { |
} else { |
Line 8375 sub tokenwrapper {
|
Line 8423 sub tokenwrapper {
|
sub getuploaded { |
sub getuploaded { |
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; |
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; |
$uri=~s/^\///; |
$uri=~s/^\///; |
$uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri; |
my $homeserver = &homeserver($cnum,$cdom); |
|
my $protocol = $protocol{$homeserver}; |
|
$protocol = 'http' if ($protocol ne 'https'); |
|
$uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri; |
my $ua=new LWP::UserAgent; |
my $ua=new LWP::UserAgent; |
my $request=new HTTP::Request($reqtype,$uri); |
my $request=new HTTP::Request($reqtype,$uri); |
my $response=$ua->request($request); |
my $response=$ua->request($request); |
Line 8457 sub filelocation {
|
Line 8508 sub filelocation {
|
|
|
sub hreflocation { |
sub hreflocation { |
my ($dir,$file)=@_; |
my ($dir,$file)=@_; |
unless (($file=~m-^http://-i) || ($file=~m-^/-)) { |
unless (($file=~m-^https?\://-i) || ($file=~m-^/-)) { |
$file=filelocation($dir,$file); |
$file=filelocation($dir,$file); |
} elsif ($file=~m-^/adm/-) { |
} elsif ($file=~m-^/adm/-) { |
$file=~s-^/adm/wrapper/-/-; |
$file=~s-^/adm/wrapper/-/-; |
Line 8653 sub get_dns {
|
Line 8704 sub get_dns {
|
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
foreach my $dns (<$config>) { |
foreach my $dns (<$config>) { |
next if ($dns !~ /^\^(\S*)/x); |
next if ($dns !~ /^\^(\S*)/x); |
$alldns{$1} = 1; |
my $line = $1; |
|
my ($host,$protocol) = split(/:/,$line); |
|
if ($protocol ne 'https') { |
|
$protocol = 'http'; |
|
} |
|
$alldns{$host} = $protocol; |
} |
} |
while (%alldns) { |
while (%alldns) { |
my ($dns) = keys(%alldns); |
my ($dns) = keys(%alldns); |
delete($alldns{$dns}); |
|
my $ua=new LWP::UserAgent; |
my $ua=new LWP::UserAgent; |
my $request=new HTTP::Request('GET',"http://$dns$url"); |
my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); |
my $response=$ua->request($request); |
my $response=$ua->request($request); |
|
delete($alldns{$dns}); |
next if ($response->is_error()); |
next if ($response->is_error()); |
my @content = split("\n",$response->content); |
my @content = split("\n",$response->content); |
&Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60); |
&Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60); |
Line 8956 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 9845 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 |