version 1.976.2.11, 2010/08/30 17:22:20
|
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 522 sub appenv {
|
Line 528 sub appenv {
|
# ----------------------------------------------------- Delete from Environment |
# ----------------------------------------------------- Delete from Environment |
|
|
sub delenv { |
sub delenv { |
my ($delthis,$regexp) = @_; |
my $delthis=shift; |
if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { |
if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { |
&logthis("<font color=\"blue\">WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
"Attempt to delete from environment ".$delthis); |
"Attempt to delete from environment ".$delthis); |
Line 535 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 ($regexp) { |
if ($key=~/^\Q$delthis\E/) { |
if ($key=~/^$delthis/) { |
delete($env{$key}); |
delete($env{$key}); |
delete($disk_env{$key}); |
delete($disk_env{$key}); |
} |
} |
|
} else { |
|
if ($key=~/^\Q$delthis\E/) { |
|
delete($env{$key}); |
|
delete($disk_env{$key}); |
|
} |
|
} |
|
} |
} |
untie(%disk_env); |
untie(%disk_env); |
} |
} |
Line 748 sub changepass {
|
Line 747 sub changepass {
|
my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_; |
my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_; |
$currentpass = &escape($currentpass); |
$currentpass = &escape($currentpass); |
$newpass = &escape($newpass); |
$newpass = &escape($newpass); |
my $lonhost = $perlvar{'lonHostID'}; |
my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context", |
my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context:$lonhost", |
|
$server); |
$server); |
if (! $answer) { |
if (! $answer) { |
&logthis("No reply on password change request to $server ". |
&logthis("No reply on password change request to $server ". |
Line 774 sub changepass {
|
Line 772 sub changepass {
|
} elsif ($answer =~ "^refused") { |
} elsif ($answer =~ "^refused") { |
&logthis("$server refused to change $uname in $udom password because ". |
&logthis("$server refused to change $uname in $udom password because ". |
"it was sent an unencrypted request to change the password."); |
"it was sent an unencrypted request to change the password."); |
} elsif ($answer =~ "invalid_client") { |
|
&logthis("$server refused to change $uname in $udom password because ". |
|
"it was a reset by e-mail originating from an invalid server."); |
|
} |
} |
return $answer; |
return $answer; |
} |
} |
Line 1285 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 2036 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 2136 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 2150 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 2163 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 2184 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 2316 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 2628 sub courserolelog {
|
Line 2661 sub courserolelog {
|
$storehash{'section'} = $sec; |
$storehash{'section'} = $sec; |
} |
} |
&instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom); |
&instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom); |
if (($trole ne 'st') || ($sec ne '')) { |
|
&devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum); |
|
} |
|
} |
} |
} |
} |
return; |
return; |
Line 2652 sub get_course_adv_roles {
|
Line 2682 sub get_course_adv_roles {
|
my %dumphash= |
my %dumphash= |
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); |
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); |
my $now=time; |
my $now=time; |
my %privileged; |
|
foreach my $entry (keys %dumphash) { |
foreach my $entry (keys %dumphash) { |
my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); |
my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); |
if (($tstart) && ($tstart<0)) { next; } |
if (($tstart) && ($tstart<0)) { next; } |
Line 2660 sub get_course_adv_roles {
|
Line 2689 sub get_course_adv_roles {
|
if (($tstart) && ($now<$tstart)) { next; } |
if (($tstart) && ($now<$tstart)) { next; } |
my ($role,$username,$domain,$section)=split(/\:/,$entry); |
my ($role,$username,$domain,$section)=split(/\:/,$entry); |
if ($username eq '' || $domain eq '') { next; } |
if ($username eq '' || $domain eq '') { next; } |
unless (ref($privileged{$domain}) eq 'HASH') { |
if ((&privileged($username,$domain)) && |
my %dompersonnel = |
(!$nothide{$username.':'.$domain})) { next; } |
&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 ($role eq 'cr') { next; } |
if ($role eq 'cr') { next; } |
if ($codes) { |
if ($codes) { |
if ($section) { $role .= ':'.$section; } |
if ($section) { $role .= ':'.$section; } |
Line 2719 sub get_my_roles {
|
Line 2735 sub get_my_roles {
|
} |
} |
my %returnhash=(); |
my %returnhash=(); |
my $now=time; |
my $now=time; |
my %privileged; |
|
foreach my $entry (keys(%dumphash)) { |
foreach my $entry (keys(%dumphash)) { |
my ($role,$tend,$tstart); |
my ($role,$tend,$tstart); |
if ($context eq 'userroles') { |
if ($context eq 'userroles') { |
Line 2768 sub get_my_roles {
|
Line 2783 sub get_my_roles {
|
} |
} |
} |
} |
if ($hidepriv) { |
if ($hidepriv) { |
if ($context eq 'userroles') { |
if ((&privileged($username,$domain)) && |
if ((&privileged($username,$domain)) && |
(!$nothide{$username.':'.$domain})) { |
(!$nothide{$username.':'.$domain})) { |
next; |
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 ($withsec) { |
if ($withsec) { |
Line 3877 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 4442 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 4458 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 4525 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 5152 sub update_allusers_table {
|
Line 5163 sub update_allusers_table {
|
'generation='.&escape($names->{'generation'}).'%%'. |
'generation='.&escape($names->{'generation'}).'%%'. |
'permanentemail='.&escape($names->{'permanentemail'}).'%%'. |
'permanentemail='.&escape($names->{'permanentemail'}).'%%'. |
'id='.&escape($names->{'id'}),$homeserver); |
'id='.&escape($names->{'id'}),$homeserver); |
return; |
my $reply = &get_query_reply($queryid); |
|
return $reply; |
} |
} |
|
|
# ------- Request retrieval of institutional classlists for course(s) |
# ------- Request retrieval of institutional classlists for course(s) |
Line 9000 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 9279 in the user's environment.db and in %env
|
Line 9308 in the user's environment.db and in %env
|
|
|
=item * |
=item * |
X<delenv()> |
X<delenv()> |
B<delenv($delthis,$regexp)>: removes all items from the session |
B<delenv($regexp)>: removes all items from the session |
environment file that begin with $delthis. If the |
environment file that matches the regular expression in $regexp. The |
optional second arg - $regexp - is true, $delthis is treated as a |
values are also delted from the current processes %env. |
regular expression, otherwise \Q$delthis\E is used. |
|
The values are also deleted from the current processes %env. |
|
|
|
=item * get_env_multiple($name) |
=item * get_env_multiple($name) |
|
|
Line 9891 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 |