|
version 1.844, 2007/03/03 02:16:10
|
version 1.868, 2007/04/11 21:37:20
|
|
Line 35 use HTTP::Headers;
|
Line 35 use HTTP::Headers;
|
| use HTTP::Date; |
use HTTP::Date; |
| # use Date::Parse; |
# use Date::Parse; |
| use vars |
use vars |
| qw(%perlvar %badServerCache %iphost %spareid |
qw(%perlvar %badServerCache %spareid |
| %libserv %pr %prp $memcache %packagetab |
%pr %prp $memcache %packagetab |
| %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount |
%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount |
| %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf |
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf |
| %domaindescription %domain_auth_def %domain_auth_arg_def |
|
| %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary |
|
| $tmpdir $_64bit %env); |
$tmpdir $_64bit %env); |
| |
|
| use IO::Socket; |
use IO::Socket; |
|
Line 146 sub logperm {
|
Line 144 sub logperm {
|
| return 1; |
return 1; |
| } |
} |
| |
|
| |
sub create_connection { |
| |
my ($hostname,$lonid) = @_; |
| |
my $client=IO::Socket::UNIX->new(Peer => $perlvar{'lonSockCreate'}, |
| |
Type => SOCK_STREAM, |
| |
Timeout => 10); |
| |
return 0 if (!$client); |
| |
print $client (join(':',$hostname,$lonid,&machine_ids($lonid))."\n"); |
| |
my $result = <$client>; |
| |
chomp($result); |
| |
return 1 if ($result eq 'done'); |
| |
return 0; |
| |
} |
| |
|
| |
|
| # -------------------------------------------------- Non-critical communication |
# -------------------------------------------------- Non-critical communication |
| sub subreply { |
sub subreply { |
| my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
|
Line 172 sub subreply {
|
Line 184 sub subreply {
|
| Timeout => 10); |
Timeout => 10); |
| if($client) { |
if($client) { |
| last; # Connected! |
last; # Connected! |
| |
} else { |
| |
&create_connection(&hostname($server),$server); |
| } |
} |
| sleep(1); # Try again later if failed connection. |
sleep(1); # Try again later if failed connection. |
| } |
} |
| my $answer; |
my $answer; |
| if ($client) { |
if ($client) { |
|
Line 720 sub idput {
|
Line 734 sub idput {
|
| # ------------------------------------------- get items from domain db files |
# ------------------------------------------- get items from domain db files |
| |
|
| sub get_dom { |
sub get_dom { |
| my ($namespace,$storearr,$udom)=@_; |
my ($namespace,$storearr,$udom,$uhome)=@_; |
| my $items=''; |
my $items=''; |
| foreach my $item (@$storearr) { |
foreach my $item (@$storearr) { |
| $items.=&escape($item).'&'; |
$items.=&escape($item).'&'; |
| } |
} |
| $items=~s/\&$//; |
$items=~s/\&$//; |
| if (!$udom) { $udom=$env{'user.domain'}; } |
if (!$udom) { |
| if (exists($domain_primary{$udom})) { |
$udom=$env{'user.domain'}; |
| my $uhome=$domain_primary{$udom}; |
if (defined(&domain($udom,'primary'))) { |
| |
$uhome=&domain($udom,'primary'); |
| |
} else { |
| |
$uhome eq ''; |
| |
} |
| |
} else { |
| |
if (!$uhome) { |
| |
if (defined(&domain($udom,'primary'))) { |
| |
$uhome=&domain($udom,'primary'); |
| |
} |
| |
} |
| |
} |
| |
if ($udom && $uhome && ($uhome ne 'no_host')) { |
| my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
| |
my %returnhash; |
| |
if ($rep =~ /^error: 2 /) { |
| |
return %returnhash; |
| |
} |
| my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
| if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { |
if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { |
| return @pairs; |
return @pairs; |
|
Line 742 sub get_dom {
|
Line 772 sub get_dom {
|
| } |
} |
| return %returnhash; |
return %returnhash; |
| } else { |
} else { |
| &logthis("get_dom failed - no primary domain server for $udom"); |
&logthis("get_dom failed - no homeserver and/or domain"); |
| } |
} |
| } |
} |
| |
|
| # -------------------------------------------- put items in domain db files |
# -------------------------------------------- put items in domain db files |
| |
|
| sub put_dom { |
sub put_dom { |
| my ($namespace,$storehash,$udom)=@_; |
my ($namespace,$storehash,$udom,$uhome)=@_; |
| if (!$udom) { $udom=$env{'user.domain'}; } |
if (!$udom) { |
| if (exists($domain_primary{$udom})) { |
$udom=$env{'user.domain'}; |
| my $uhome=$domain_primary{$udom}; |
if (defined(&domain($udom,'primary'))) { |
| |
$uhome=&domain($udom,'primary'); |
| |
} else { |
| |
$uhome eq ''; |
| |
} |
| |
} else { |
| |
if (!$uhome) { |
| |
if (defined(&domain($udom,'primary'))) { |
| |
$uhome=&domain($udom,'primary'); |
| |
} |
| |
} |
| |
} |
| |
if ($udom && $uhome && ($uhome ne 'no_host')) { |
| my $items=''; |
my $items=''; |
| foreach my $item (keys(%$storehash)) { |
foreach my $item (keys(%$storehash)) { |
| $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
|
Line 760 sub put_dom {
|
Line 802 sub put_dom {
|
| $items=~s/\&$//; |
$items=~s/\&$//; |
| return &reply("putdom:$udom:$namespace:$items",$uhome); |
return &reply("putdom:$udom:$namespace:$items",$uhome); |
| } else { |
} else { |
| &logthis("put_dom failed - no primary domain server for $udom"); |
&logthis("put_dom failed - no homeserver and/or domain"); |
| } |
} |
| } |
} |
| |
|
| sub retrieve_inst_usertypes { |
sub retrieve_inst_usertypes { |
| my ($udom) = @_; |
my ($udom) = @_; |
| my (%returnhash,@order); |
my (%returnhash,@order); |
| if (exists($domain_primary{$udom})) { |
if (defined(&domain($udom,'primary'))) { |
| my $uhome=$domain_primary{$udom}; |
my $uhome=&domain($udom,'primary'); |
| my $rep=&reply("inst_usertypes:$udom",$uhome); |
my $rep=&reply("inst_usertypes:$udom",$uhome); |
| my ($hashitems,$orderitems) = split(/:/,$rep); |
my ($hashitems,$orderitems) = split(/:/,$rep); |
| my @pairs=split(/\&/,$hashitems); |
my @pairs=split(/\&/,$hashitems); |
|
Line 788 sub retrieve_inst_usertypes {
|
Line 830 sub retrieve_inst_usertypes {
|
| return (\%returnhash,\@order); |
return (\%returnhash,\@order); |
| } |
} |
| |
|
| |
sub is_domainimage { |
| |
my ($url) = @_; |
| |
if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+-) { |
| |
if (&domain($1) ne '') { |
| |
return '1'; |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| # --------------------------------------------------- Assign a key to a student |
# --------------------------------------------------- Assign a key to a student |
| |
|
| sub assign_access_key { |
sub assign_access_key { |
|
Line 1012 my %remembered;
|
Line 1064 my %remembered;
|
| my %accessed; |
my %accessed; |
| my $kicks=0; |
my $kicks=0; |
| my $hits=0; |
my $hits=0; |
| |
sub make_key { |
| |
my ($name,$id) = @_; |
| |
if (length($id) > 200) { $id=length($id).':'.&Digest::MD5::md5_hex($id); } |
| |
return &escape($name.':'.$id); |
| |
} |
| |
|
| sub devalidate_cache_new { |
sub devalidate_cache_new { |
| my ($name,$id,$debug) = @_; |
my ($name,$id,$debug) = @_; |
| if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } |
if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } |
| $id=&escape($name.':'.$id); |
$id=&make_key($name,$id); |
| $memcache->delete($id); |
$memcache->delete($id); |
| delete($remembered{$id}); |
delete($remembered{$id}); |
| delete($accessed{$id}); |
delete($accessed{$id}); |
|
Line 1023 sub devalidate_cache_new {
|
Line 1081 sub devalidate_cache_new {
|
| |
|
| sub is_cached_new { |
sub is_cached_new { |
| my ($name,$id,$debug) = @_; |
my ($name,$id,$debug) = @_; |
| $id=&escape($name.':'.$id); |
$id=&make_key($name,$id); |
| if (exists($remembered{$id})) { |
if (exists($remembered{$id})) { |
| if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } |
if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } |
| $accessed{$id}=[&gettimeofday()]; |
$accessed{$id}=[&gettimeofday()]; |
|
Line 1046 sub is_cached_new {
|
Line 1104 sub is_cached_new {
|
| |
|
| sub do_cache_new { |
sub do_cache_new { |
| my ($name,$id,$value,$time,$debug) = @_; |
my ($name,$id,$value,$time,$debug) = @_; |
| $id=&escape($name.':'.$id); |
$id=&make_key($name,$id); |
| my $setvalue=$value; |
my $setvalue=$value; |
| if (!defined($setvalue)) { |
if (!defined($setvalue)) { |
| $setvalue='__undef__'; |
$setvalue='__undef__'; |
|
Line 1496 sub clean_filename {
|
Line 1554 sub clean_filename {
|
| # $coursedoc - if true up to the current course |
# $coursedoc - if true up to the current course |
| # if false |
# if false |
| # $subdir - directory in userfile to store the file into |
# $subdir - directory in userfile to store the file into |
| # $parser, $allfiles, $codebase - unknown |
# $parser - instruction to parse file for objects ($parser = parse) |
| # |
# $allfiles - reference to hash for embedded objects |
| |
# $codebase - reference to hash for codebase of java objects |
| |
# $desuname - username for permanent storage of uploaded file |
| |
# $dsetudom - domain for permanaent storage of uploaded file |
| |
# $thumbwidth - width (pixels) of thumbnail to make for uploaded image |
| |
# $thumbheight - height (pixels) of thumbnail to make for uploaded image |
| |
# |
| # output: url of file in userspace, or error: <message> |
# output: url of file in userspace, or error: <message> |
| # or /adm/notfound.html if failure to upload occurse |
# or /adm/notfound.html if failure to upload occurse |
| |
|
| |
|
| sub userfileupload { |
sub userfileupload { |
| my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_; |
my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname, |
| |
$destudom,$thumbwidth,$thumbheight)=@_; |
| if (!defined($subdir)) { $subdir='unknown'; } |
if (!defined($subdir)) { $subdir='unknown'; } |
| my $fname=$env{'form.'.$formname.'.filename'}; |
my $fname=$env{'form.'.$formname.'.filename'}; |
| $fname=&clean_filename($fname); |
$fname=&clean_filename($fname); |
|
Line 1550 sub userfileupload {
|
Line 1615 sub userfileupload {
|
| if ($env{'form.folder'} =~ m/^(default|supplemental)/) { |
if ($env{'form.folder'} =~ m/^(default|supplemental)/) { |
| return &finishuserfileupload($docuname,$docudom, |
return &finishuserfileupload($docuname,$docudom, |
| $formname,$fname,$parser,$allfiles, |
$formname,$fname,$parser,$allfiles, |
| $codebase); |
$codebase,$thumbwidth,$thumbheight); |
| } else { |
} else { |
| $fname=$env{'form.folder'}.'/'.$fname; |
$fname=$env{'form.folder'}.'/'.$fname; |
| return &process_coursefile('uploaddoc',$docuname,$docudom, |
return &process_coursefile('uploaddoc',$docuname,$docudom, |
|
Line 1560 sub userfileupload {
|
Line 1625 sub userfileupload {
|
| } elsif (defined($destuname)) { |
} elsif (defined($destuname)) { |
| my $docuname=$destuname; |
my $docuname=$destuname; |
| my $docudom=$destudom; |
my $docudom=$destudom; |
| return &finishuserfileupload($docuname,$docudom,$formname, |
return &finishuserfileupload($docuname,$docudom,$formname,$fname, |
| $fname,$parser,$allfiles,$codebase); |
$parser,$allfiles,$codebase, |
| |
$thumbwidth,$thumbheight); |
| |
|
| } else { |
} else { |
| my $docuname=$env{'user.name'}; |
my $docuname=$env{'user.name'}; |
|
Line 1570 sub userfileupload {
|
Line 1636 sub userfileupload {
|
| $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; |
$docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; |
| $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; |
$docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; |
| } |
} |
| return &finishuserfileupload($docuname,$docudom,$formname, |
return &finishuserfileupload($docuname,$docudom,$formname,$fname, |
| $fname,$parser,$allfiles,$codebase); |
$parser,$allfiles,$codebase, |
| |
$thumbwidth,$thumbheight); |
| } |
} |
| } |
} |
| |
|
| sub finishuserfileupload { |
sub finishuserfileupload { |
| my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_; |
my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase, |
| |
$thumbwidth,$thumbheight) = @_; |
| my $path=$docudom.'/'.$docuname.'/'; |
my $path=$docudom.'/'.$docuname.'/'; |
| my $filepath=$perlvar{'lonDocRoot'}; |
my $filepath=$perlvar{'lonDocRoot'}; |
| my ($fnamepath,$file); |
my ($fnamepath,$file,$fetchthumb); |
| $file=$fname; |
$file=$fname; |
| if ($fname=~m|/|) { |
if ($fname=~m|/|) { |
| ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|); |
($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|); |
|
Line 1615 sub finishuserfileupload {
|
Line 1683 sub finishuserfileupload {
|
| ' for embedded media: '.$parse_result); |
' for embedded media: '.$parse_result); |
| } |
} |
| } |
} |
| |
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { |
| |
my $input = $filepath.'/'.$file; |
| |
my $output = $filepath.'/'.'tn-'.$file; |
| |
my $thumbsize = $thumbwidth.'x'.$thumbheight; |
| |
system("convert -sample $thumbsize $input $output"); |
| |
if (-e $filepath.'/'.'tn-'.$file) { |
| |
$fetchthumb = 1; |
| |
} |
| |
} |
| |
|
| # 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) { |
| |
my $thumbresult= &reply('fetchuserfile:'.$path.'tn-'.$file,$docuhome); |
| |
if ($thumbresult ne 'ok') { |
| |
&logthis('Failed to transfer '.$path.'tn-'.$file.' to host '. |
| |
$docuhome.': '.$thumbresult); |
| |
} |
| |
} |
| # |
# |
| # Return the URL to it |
# Return the URL to it |
| return '/uploaded/'.$path.$file; |
return '/uploaded/'.$path.$file; |
|
Line 1627 sub finishuserfileupload {
|
Line 1712 sub finishuserfileupload {
|
| &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome. |
&logthis('Failed to transfer '.$path.$file.' to host '.$docuhome. |
| ': '.$fetchresult); |
': '.$fetchresult); |
| return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
| } |
} |
| } |
} |
| |
|
| sub extract_embedded_items { |
sub extract_embedded_items { |
|
Line 2049 sub get_course_adv_roles {
|
Line 2134 sub get_course_adv_roles {
|
| } |
} |
| |
|
| sub get_my_roles { |
sub get_my_roles { |
| my ($uname,$udom,$types,$roles,$roledoms)=@_; |
my ($uname,$udom,$context,$types,$roles,$roledoms)=@_; |
| unless (defined($uname)) { $uname=$env{'user.name'}; } |
unless (defined($uname)) { $uname=$env{'user.name'}; } |
| unless (defined($udom)) { $udom=$env{'user.domain'}; } |
unless (defined($udom)) { $udom=$env{'user.domain'}; } |
| my %dumphash= |
my %dumphash; |
| |
if ($context eq 'userroles') { |
| |
%dumphash = &dump('roles',$udom,$uname); |
| |
} else { |
| |
%dumphash= |
| &dump('nohist_userroles',$udom,$uname); |
&dump('nohist_userroles',$udom,$uname); |
| |
} |
| my %returnhash=(); |
my %returnhash=(); |
| my $now=time; |
my $now=time; |
| foreach my $entry (keys(%dumphash)) { |
foreach my $entry (keys(%dumphash)) { |
| my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); |
my ($role,$tend,$tstart); |
| |
if ($context eq 'userroles') { |
| |
($role,$tend,$tstart)=split(/_/,$dumphash{$entry}); |
| |
} else { |
| |
($tend,$tstart)=split(/\:/,$dumphash{$entry}); |
| |
} |
| if (($tstart) && ($tstart<0)) { next; } |
if (($tstart) && ($tstart<0)) { next; } |
| my $status = 'active'; |
my $status = 'active'; |
| if (($tend) && ($tend<$now)) { |
if (($tend) && ($tend<$now)) { |
|
Line 2075 sub get_my_roles {
|
Line 2170 sub get_my_roles {
|
| next; |
next; |
| } |
} |
| } |
} |
| my ($role,$username,$domain,$section)=split(/\:/,$entry); |
my ($rolecode,$username,$domain,$section,$area); |
| |
if ($context eq 'userroles') { |
| |
($area,$rolecode) = split(/_/,$entry); |
| |
(undef,$domain,$username,$section) = split(/\//,$area); |
| |
} else { |
| |
($role,$username,$domain,$section) = split(/\:/,$entry); |
| |
} |
| if (ref($roledoms) eq 'ARRAY') { |
if (ref($roledoms) eq 'ARRAY') { |
| if (!grep(/^\Q$domain\E$/,@{$roledoms})) { |
if (!grep(/^\Q$domain\E$/,@{$roledoms})) { |
| next; |
next; |
|
Line 2085 sub get_my_roles {
|
Line 2186 sub get_my_roles {
|
| if (!grep(/^\Q$role\E$/,@{$roles})) { |
if (!grep(/^\Q$role\E$/,@{$roles})) { |
| next; |
next; |
| } |
} |
| } |
} |
| $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; |
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; |
| } |
} |
| return %returnhash; |
return %returnhash; |
|
Line 2133 sub courseiddump {
|
Line 2234 sub courseiddump {
|
| my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_; |
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_; |
| my %returnhash=(); |
my %returnhash=(); |
| unless ($domfilter) { $domfilter=''; } |
unless ($domfilter) { $domfilter=''; } |
| foreach my $tryserver (keys %libserv) { |
my %libserv = &all_library(); |
| if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) { |
foreach my $tryserver (keys(%libserv)) { |
| if ((!$domfilter) || (&host_domain($tryserver) eq $domfilter)) { |
if ( ( $hostidflag == 1 |
| |
&& grep(/^\Q$tryserver\E$/,@{$hostidref}) ) |
| |
|| (!defined($hostidflag)) ) { |
| |
|
| |
if ($domfilter eq '' |
| |
|| (&host_domain($tryserver) eq $domfilter)) { |
| foreach my $line ( |
foreach my $line ( |
| split(/\&/,&reply('courseiddump:'.&host_domain($tryserver).':'. |
split(/\&/,&reply('courseiddump:'.&host_domain($tryserver).':'. |
| $sincefilter.':'.&escape($descfilter).':'. |
$sincefilter.':'.&escape($descfilter).':'. |
|
Line 2165 sub dcmailput {
|
Line 2271 sub dcmailput {
|
| sub dcmaildump { |
sub dcmaildump { |
| my ($dom,$startdate,$enddate,$senders) = @_; |
my ($dom,$startdate,$enddate,$senders) = @_; |
| my %returnhash=(); |
my %returnhash=(); |
| if (exists($domain_primary{$dom})) { |
|
| |
if (defined(&domain($dom,'primary'))) { |
| my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'. |
my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'. |
| &escape($enddate).':'; |
&escape($enddate).':'; |
| my @esc_senders=map { &escape($_)} @$senders; |
my @esc_senders=map { &escape($_)} @$senders; |
| $cmd.=&escape(join('&',@esc_senders)); |
$cmd.=&escape(join('&',@esc_senders)); |
| foreach my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) { |
foreach my $line (split(/\&/,&reply($cmd,&domain($dom,'primary')))) { |
| my ($key,$value) = split(/\=/,$line,2); |
my ($key,$value) = split(/\=/,$line,2); |
| if (($key) && ($value)) { |
if (($key) && ($value)) { |
| $returnhash{&unescape($key)} = &unescape($value); |
$returnhash{&unescape($key)} = &unescape($value); |
|
Line 3504 sub get_portfolio_access {
|
Line 3611 sub get_portfolio_access {
|
| } |
} |
| if (@users > 0) { |
if (@users > 0) { |
| foreach my $userkey (@users) { |
foreach my $userkey (@users) { |
| if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) { |
if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') { |
| return 'ok'; |
foreach my $item (@{$access_hash->{$userkey}{'users'}}) { |
| } |
if (ref($item) eq 'HASH') { |
| |
if (($item->{'uname'} eq $env{'user.name'}) && |
| |
($item->{'udom'} eq $env{'user.domain'})) { |
| |
return 'ok'; |
| |
} |
| |
} |
| |
} |
| |
} |
| } |
} |
| } |
} |
| my %roleshash; |
my %roleshash; |
|
Line 4170 sub definerole {
|
Line 4284 sub definerole {
|
| sub metadata_query { |
sub metadata_query { |
| my ($query,$custom,$customshow,$server_array)=@_; |
my ($query,$custom,$customshow,$server_array)=@_; |
| my %rhash; |
my %rhash; |
| |
my %libserv = &all_library(); |
| my @server_list = (defined($server_array) ? @$server_array |
my @server_list = (defined($server_array) ? @$server_array |
| : keys(%libserv) ); |
: keys(%libserv) ); |
| for my $server (@server_list) { |
for my $server (@server_list) { |
|
Line 4322 sub courselog_query {
|
Line 4437 sub courselog_query {
|
| } |
} |
| |
|
| sub userlog_query { |
sub userlog_query { |
| |
# |
| |
# possible filters: |
| |
# action: log check role |
| |
# start: timestamp |
| |
# end: timestamp |
| |
# |
| my ($uname,$udom,%filters)=@_; |
my ($uname,$udom,%filters)=@_; |
| return &log_query($uname,$udom,'userlog',%filters); |
return &log_query($uname,$udom,'userlog',%filters); |
| } |
} |
|
Line 5038 sub createcourse {
|
Line 5159 sub createcourse {
|
| } |
} |
| # ------------------------------------------------ Check supplied server name |
# ------------------------------------------------ Check supplied server name |
| $course_server = $env{'user.homeserver'} if (! defined($course_server)); |
$course_server = $env{'user.homeserver'} if (! defined($course_server)); |
| if (! exists($libserv{$course_server})) { |
if (! &is_library($course_server)) { |
| return 'error:bad server name '.$course_server; |
return 'error:bad server name '.$course_server; |
| } |
} |
| # ------------------------------------------------------------- Make the course |
# ------------------------------------------------------------- Make the course |
|
Line 6171 sub packages_tab_default {
|
Line 6292 sub packages_tab_default {
|
| $do_default=1; |
$do_default=1; |
| } elsif ($pack_type eq 'extension') { |
} elsif ($pack_type eq 'extension') { |
| push(@extension,[$package,$pack_type,$pack_part]); |
push(@extension,[$package,$pack_type,$pack_part]); |
| } else { |
} elsif ($pack_part eq $part) { |
| |
# only look at packages defaults for packages that this id is |
| push(@specifics,[$package,$pack_type,$pack_part]); |
push(@specifics,[$package,$pack_type,$pack_part]); |
| } |
} |
| } |
} |
|
Line 6889 sub getCODE {
|
Line 7011 sub getCODE {
|
| |
|
| sub rndseed { |
sub rndseed { |
| my ($symb,$courseid,$domain,$username)=@_; |
my ($symb,$courseid,$domain,$username)=@_; |
| |
|
| my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser(); |
my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser(); |
| if (!$symb) { |
if (!$symb) { |
| unless ($symb=$wsymb) { return time; } |
unless ($symb=$wsymb) { return time; } |
|
Line 7398 sub hreflocation {
|
Line 7519 sub hreflocation {
|
| } |
} |
| |
|
| sub current_machine_domains { |
sub current_machine_domains { |
| my $hostname=&hostname($perlvar{'lonHostID'}); |
return &machine_domains(&hostname($perlvar{'lonHostID'})); |
| |
} |
| |
|
| |
sub machine_domains { |
| |
my ($hostname) = @_; |
| my @domains; |
my @domains; |
| my %hostname = &all_hostnames(); |
my %hostname = &all_hostnames(); |
| while( my($id, $name) = each(%hostname)) { |
while( my($id, $name) = each(%hostname)) { |
|
Line 7411 sub current_machine_domains {
|
Line 7536 sub current_machine_domains {
|
| } |
} |
| |
|
| sub current_machine_ids { |
sub current_machine_ids { |
| my $hostname=&hostname($perlvar{'lonHostID'}); |
return &machine_ids(&hostname($perlvar{'lonHostID'})); |
| |
} |
| |
|
| |
sub machine_ids { |
| |
my ($hostname) = @_; |
| |
$hostname ||= &hostname($perlvar{'lonHostID'}); |
| my @ids; |
my @ids; |
| my %hostname = &all_hostnames(); |
my %hostname = &all_hostnames(); |
| while( my($id, $name) = each(%hostname)) { |
while( my($id, $name) = each(%hostname)) { |
|
Line 7551 sub goodbye {
|
Line 7681 sub goodbye {
|
| &logthis("Shutting down"); |
&logthis("Shutting down"); |
| } |
} |
| |
|
| BEGIN { |
sub get_dns { |
| # ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
my ($url,$func) = @_; |
| unless ($readit) { |
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
| { |
foreach my $dns (<$config>) { |
| my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); |
next if ($dns !~ /^\^(\S*)/x); |
| %perlvar = (%perlvar,%{$configvars}); |
$dns = $1; |
| |
my $ua=new LWP::UserAgent; |
| |
my $request=new HTTP::Request('GET',"http://$dns$url"); |
| |
my $response=$ua->request($request); |
| |
next if ($response->is_error()); |
| |
my @content = split("\n",$response->content); |
| |
&$func(\@content); |
| |
} |
| |
close($config); |
| } |
} |
| |
|
| # ------------------------------------------------------------ Read domain file |
# ------------------------------------------------------------ Read domain file |
| { |
{ |
| %domaindescription = (); |
my $loaded; |
| %domain_auth_def = (); |
my %domain; |
| %domain_auth_arg_def = (); |
|
| my $fh; |
sub parse_domain_tab { |
| if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) { |
my ($lines) = @_; |
| while (my $line = <$fh>) { |
foreach my $line (@$lines) { |
| next if ($line =~ /^(\#|\s*$)/); |
next if ($line =~ /^(\#|\s*$ )/x); |
| # next if /^\#/; |
|
| chomp $line; |
chomp($line); |
| my ($domain, $domain_description, $def_auth, $def_auth_arg, |
my ($name,@elements) = split(/:/,$line,9); |
| $def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9); |
my %this_domain; |
| $domain_auth_def{$domain}=$def_auth; |
foreach my $field ('description', 'auth_def', 'auth_arg_def', |
| $domain_auth_arg_def{$domain}=$def_auth_arg; |
'lang_def', 'city', 'longi', 'lati', |
| $domaindescription{$domain}=$domain_description; |
'primary') { |
| $domain_lang_def{$domain}=$def_lang; |
$this_domain{$field} = shift(@elements); |
| $domain_city{$domain}=$city; |
} |
| $domain_longi{$domain}=$longi; |
$domain{$name} = \%this_domain; |
| $domain_lati{$domain}=$lati; |
} |
| $domain_primary{$domain}=$primary; |
} |
| |
|
| |
sub reset_domain_info { |
| |
undef($loaded); |
| |
undef(%domain); |
| |
} |
| |
|
| |
sub load_domain_tab { |
| |
&get_dns('/adm/dns/domain',\&parse_domain_tab); |
| |
my $fh; |
| |
if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { |
| |
my @lines = <$fh>; |
| |
&parse_domain_tab(\@lines); |
| |
} |
| |
close($fh); |
| |
$loaded = 1; |
| |
} |
| |
|
| |
sub domain { |
| |
&load_domain_tab() if (!$loaded); |
| |
|
| # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); |
my ($name,$what) = @_; |
| # &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); |
return if ( !exists($domain{$name}) ); |
| |
|
| |
if (!$what) { |
| |
return $domain{$name}{'description'}; |
| } |
} |
| |
return $domain{$name}{$what}; |
| } |
} |
| close ($fh); |
|
| } |
} |
| |
|
| |
|
|
Line 7593 BEGIN {
|
Line 7752 BEGIN {
|
| { |
{ |
| my %hostname; |
my %hostname; |
| my %hostdom; |
my %hostdom; |
| open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
my %libserv; |
| |
my $loaded; |
| |
|
| while (my $configline=<$config>) { |
sub parse_hosts_tab { |
| next if ($configline =~ /^(\#|\s*$)/); |
my ($file) = @_; |
| chomp($configline); |
foreach my $configline (@$file) { |
| my ($id,$domain,$role,$name)=split(/:/,$configline); |
next if ($configline =~ /^(\#|\s*$ )/x); |
| $name=~s/\s//g; |
next if ($configline =~ /^\^/); |
| if ($id && $domain && $role && $name) { |
chomp($configline); |
| $hostname{$id}=$name; |
my ($id,$domain,$role,$name)=split(/:/,$configline); |
| $hostdom{$id}=$domain; |
$name=~s/\s//g; |
| if ($role eq 'library') { $libserv{$id}=$name; } |
if ($id && $domain && $role && $name) { |
| } |
$hostname{$id}=$name; |
| |
$hostdom{$id}=$domain; |
| |
if ($role eq 'library') { $libserv{$id}=$name; } |
| |
} |
| |
} |
| |
} |
| |
|
| |
sub reset_hosts_info { |
| |
&reset_domain_info(); |
| |
&reset_hosts_ip_info(); |
| |
undef(%hostname); |
| |
undef(%hostdom); |
| |
undef(%libserv); |
| |
undef($loaded); |
| |
} |
| |
|
| |
sub load_hosts_tab { |
| |
&get_dns('/adm/dns/hosts',\&parse_hosts_tab); |
| |
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
| |
my @config = <$config>; |
| |
&parse_hosts_tab(\@config); |
| |
close($config); |
| |
$loaded=1; |
| } |
} |
| close($config); |
|
| # FIXME: dev server don't want this, production servers _do_ want this |
|
| #&get_iphost(); |
|
| |
|
| sub hostname { |
sub hostname { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| my ($lonid) = @_; |
my ($lonid) = @_; |
| return $hostname{$lonid}; |
return $hostname{$lonid}; |
| } |
} |
| |
|
| sub all_hostnames { |
sub all_hostnames { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| return %hostname; |
return %hostname; |
| } |
} |
| |
|
| |
sub is_library { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
return exists($libserv{$_[0]}); |
| |
} |
| |
|
| |
sub all_library { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
return %libserv; |
| |
} |
| |
|
| sub get_servers { |
sub get_servers { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| my ($domain,$type) = @_; |
my ($domain,$type) = @_; |
| my %possible_hosts = ($type eq 'library') ? %libserv |
my %possible_hosts = ($type eq 'library') ? %libserv |
| : %hostname; |
: %hostname; |
|
Line 7637 BEGIN {
|
Line 7836 BEGIN {
|
| } |
} |
| return %result; |
return %result; |
| } |
} |
| |
|
| sub host_domain { |
sub host_domain { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| my ($lonid) = @_; |
my ($lonid) = @_; |
| return $hostdom{$lonid}; |
return $hostdom{$lonid}; |
| } |
} |
| |
|
| sub all_domains { |
sub all_domains { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| my %seen; |
my %seen; |
| my @uniq = grep(!$seen{$_}++, values(%hostdom)); |
my @uniq = grep(!$seen{$_}++, values(%hostdom)); |
| return @uniq; |
return @uniq; |
| } |
} |
| } |
} |
| |
|
| sub get_hosts_from_ip { |
{ |
| my ($ip) = @_; |
my %iphost; |
| my %iphosts = &get_iphost(); |
my %name_to_ip; |
| if (ref($iphosts{$ip})) { |
my %lonid_to_ip; |
| return @{$iphosts{$ip}}; |
sub get_hosts_from_ip { |
| |
my ($ip) = @_; |
| |
my %iphosts = &get_iphost(); |
| |
if (ref($iphosts{$ip})) { |
| |
return @{$iphosts{$ip}}; |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub reset_hosts_ip_info { |
| |
undef(%iphost); |
| |
undef(%name_to_ip); |
| |
undef(%lonid_to_ip); |
| } |
} |
| return; |
|
| } |
|
| |
|
| sub get_iphost { |
sub get_host_ip { |
| if (%iphost) { return %iphost; } |
my ($lonid) = @_; |
| my %name_to_ip; |
if (exists($lonid_to_ip{$lonid})) { |
| my %hostname = &all_hostnames(); |
return $lonid_to_ip{$lonid}; |
| foreach my $id (keys(%hostname)) { |
} |
| my $name=$hostname{$id}; |
my $name=&hostname($lonid); |
| my $ip; |
my $ip = gethostbyname($name); |
| if (!exists($name_to_ip{$name})) { |
return if (!$ip || length($ip) ne 4); |
| $ip = gethostbyname($name); |
$ip=inet_ntoa($ip); |
| if (!$ip || length($ip) ne 4) { |
$name_to_ip{$name} = $ip; |
| &logthis("Skipping host $id name $name no IP found"); |
$lonid_to_ip{$lonid} = $ip; |
| next; |
return $ip; |
| |
} |
| |
|
| |
sub get_iphost { |
| |
if (%iphost) { return %iphost; } |
| |
my %hostname = &all_hostnames(); |
| |
foreach my $id (keys(%hostname)) { |
| |
my $name=&hostname($id); |
| |
my $ip; |
| |
if (!exists($name_to_ip{$name})) { |
| |
$ip = gethostbyname($name); |
| |
if (!$ip || length($ip) ne 4) { |
| |
&logthis("Skipping host $id name $name no IP found"); |
| |
next; |
| |
} |
| |
$ip=inet_ntoa($ip); |
| |
$name_to_ip{$name} = $ip; |
| |
} else { |
| |
$ip = $name_to_ip{$name}; |
| } |
} |
| $ip=inet_ntoa($ip); |
$lonid_to_ip{$id} = $ip; |
| $name_to_ip{$name} = $ip; |
push(@{$iphost{$ip}},$id); |
| } else { |
|
| $ip = $name_to_ip{$name}; |
|
| } |
} |
| push(@{$iphost{$ip}},$id); |
return %iphost; |
| } |
} |
| return %iphost; |
|
| } |
} |
| |
|
| |
BEGIN { |
| |
|
| |
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
| |
unless ($readit) { |
| |
{ |
| |
my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); |
| |
%perlvar = (%perlvar,%{$configvars}); |
| |
} |
| |
|
| |
|
| # ------------------------------------------------------ Read spare server file |
# ------------------------------------------------------ Read spare server file |
| { |
{ |
| open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); |
open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); |
|
Line 8012 X<userenvironment()>
|
Line 8251 X<userenvironment()>
|
| B<userenvironment($udom,$uname,@what)>: gets the values of the keys |
B<userenvironment($udom,$uname,@what)>: gets the values of the keys |
| passed in @what from the requested user's environment, returns a hash |
passed in @what from the requested user's environment, returns a hash |
| |
|
| |
=item * |
| |
X<userlog_query()> |
| |
B<userlog_query($uname,$udom,%filters)>: retrieves data from a user's |
| |
activity.log file. %filters defines filters applied when parsing the |
| |
log file. These can be start or end timestamps, or the type of action |
| |
- log to look for Login or Logout events, check for Checkin or |
| |
Checkout, role for role selection. The response is in the form |
| |
timestamp1:hostid1:event1×tamp2:hostid2:event2 where events are |
| |
escaped strings of the action recorded in the activity.log file. |
| |
|
| =back |
=back |
| |
|
| =head2 User Roles |
=head2 User Roles |
|
Line 8041 explanation of a user role term
|
Line 8290 explanation of a user role term
|
| |
|
| =item * |
=item * |
| |
|
| get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are |
get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) : |
| optional. Returns a hash of a user's roles, with keys set to |
All arguments are optional. Returns a hash of a roles, either for |
| colon-sparated $uname,$udom,and $role, and value set to |
co-author/assistant author roles for a user's Construction Space |
| colon-separated start and end times for the role. If no username and |
(default), or if $context is 'user', roles for the user himself, |
| domain are specified, will default to current user/domain. Types, |
In the hash, keys are set to colon-sparated $uname,$udom,and $role, |
| roles, and roledoms are references to arrays, of role statuses |
and value is set to colon-separated start and end times for the role. |
| (active, future or previous), roles (e.g., cc,in, st etc.) and domains |
If no username and domain are specified, will default to current |
| of the roles which can be used to restrict the list if roles |
user/domain. Types, roles, and roledoms are references to arrays, |
| reported. If no array ref is provided for types, will default to |
of role statuses (active, future or previous), roles |
| return only active roles. |
(e.g., cc,in, st etc.) and domains of the roles which can be used |
| |
to restrict the list of roles reported. If no array ref is |
| |
provided for types, will default to return only active roles. |
| |
|
| =back |
=back |
| |
|
|
Line 8475 critical subroutine
|
Line 8726 critical subroutine
|
| |
|
| =item * |
=item * |
| |
|
| get_dom($namespace,$storearr,$udomain) : returns hash with keys from array |
get_dom($namespace,$storearr,$udom,$uhome) : returns hash with keys from |
| reference filled in from namespace found in domain level on primary domain server ($udomain is optional) |
array reference filled in from namespace found in domain level on either |
| |
specified domain server ($uhome) or primary domain server ($udom and $uhome are optional). |
| |
|
| =item * |
=item * |
| |
|
| put_dom($namespace,$storehash,$udomain) : stores hash in namespace at domain level on primary domain server ($udomain is optional) |
put_dom($namespace,$storehash,$udom,$uhome) : stores hash in namespace at |
| |
domain level either on specified domain server ($uhome) or primary domain |
| |
server ($udom and $uhome are optional) |
| |
|
| =back |
=back |
| |
|
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl