|
version 1.851, 2007/03/28 00:05:45
|
version 1.862, 2007/04/04 00:07:07
|
|
Line 145 sub logperm {
|
Line 145 sub logperm {
|
| } |
} |
| |
|
| sub create_connection { |
sub create_connection { |
| my ($server) = @_; |
my ($hostname,$lonid) = @_; |
| my $client=IO::Socket::UNIX->new(Peer => $perlvar{'lonSockCreate'}, |
my $client=IO::Socket::UNIX->new(Peer => $perlvar{'lonSockCreate'}, |
| Type => SOCK_STREAM, |
Type => SOCK_STREAM, |
| Timeout => 10); |
Timeout => 10); |
| return 0 if (!$client); |
return 0 if (!$client); |
| print $client ("$server\n"); |
print $client (join(':',$hostname,$lonid,&machine_ids($lonid))."\n"); |
| my $result = <$client>; |
my $result = <$client>; |
| chomp($result); |
chomp($result); |
| return 1 if ($result eq 'done'); |
return 1 if ($result eq 'done'); |
|
Line 185 sub subreply {
|
Line 185 sub subreply {
|
| if($client) { |
if($client) { |
| last; # Connected! |
last; # Connected! |
| } else { |
} else { |
| &create_connection(&hostname($server)); |
&create_connection(&hostname($server),$server); |
| } |
} |
| sleep(1); # Try again later if failed connection. |
sleep(1); # Try again later if failed connection. |
| } |
} |
|
Line 671 sub homeserver {
|
Line 671 sub homeserver {
|
| return 'no_host'; |
return 'no_host'; |
| } |
} |
| |
|
| |
# ---------------------- Get domain configuration for a domain |
| |
sub get_domainconf { |
| |
my ($udom) = @_; |
| |
my $cachetime=1800; |
| |
my ($result,$cached)=&is_cached_new('domainconfig',$udom); |
| |
if (defined($cached)) { return %{$result}; } |
| |
|
| |
if ($udom eq '') { |
| |
$udom = &Apache::loncommon::determinedomain(); |
| |
} |
| |
my %domconfig = &get_dom('configuration',['login','rolecolors'],$udom); |
| |
my %designhash; |
| |
if (keys(%domconfig) > 0) { |
| |
if (ref($domconfig{'login'}) eq 'HASH') { |
| |
foreach my $key (keys(%{$domconfig{'login'}})) { |
| |
$designhash{$udom.'.login.'.$key}=$domconfig{'login'}{$key}; |
| |
} |
| |
} |
| |
if (ref($domconfig{'rolecolors'}) eq 'HASH') { |
| |
foreach my $role (keys(%{$domconfig{'rolecolors'}})) { |
| |
if (ref($domconfig{'rolecolors'}{$role}) eq 'HASH') { |
| |
foreach my $item (keys(%{$domconfig{'rolecolors'}{$role}})) { |
| |
$designhash{$udom.'.'.$role.'.'.$item}=$domconfig{'rolecolors'}{$role}{$item}; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} else { |
| |
my $designdir=$perlvar{'lonTabDir'}.'/lonDomColors'; |
| |
my $designfile = $designdir.'/'.$udom.'.tab'; |
| |
if (-e $designfile) { |
| |
if ( open (my $fh,"<$designfile") ) { |
| |
while (my $line = <$fh>) { |
| |
next if ($line =~ /^\#/); |
| |
chomp($line); |
| |
my ($key,$val)=(split(/\=/,$line)); |
| |
if ($val) { $designhash{$udom.'.'.$key}=$val; } |
| |
} |
| |
close($fh); |
| |
} |
| |
} |
| |
if (-e '/home/httpd/html/adm/lonDomLogos/'.$udom.'.gif') { |
| |
$designhash{$udom.'.login.domlogo'} = |
| |
&lonhttpdurl("/adm/lonDomLogos/$udom.gif"); |
| |
} |
| |
} |
| |
&do_cache_new('domainconfig',$udom,\%designhash,$cachetime); |
| |
return %designhash; |
| |
} |
| |
|
| |
sub devalidate_domconfig_cache { |
| |
my ($udom)=@_; |
| |
&devalidate_cache_new('domainconfig',$udom); |
| |
} |
| |
|
| # ------------------------------------- Find the usernames behind a list of IDs |
# ------------------------------------- Find the usernames behind a list of IDs |
| |
|
| sub idget { |
sub idget { |
|
Line 734 sub idput {
|
Line 789 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 (defined(&domain($udom,'primary'))) { |
$udom=$env{'user.domain'}; |
| my $uhome=&domain($udom,'primary'); |
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 @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) { |
|
Line 756 sub get_dom {
|
Line 823 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 (defined(&domain($udom,'primary'))) { |
$udom=$env{'user.domain'}; |
| my $uhome=&domain($udom,'primary'); |
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 774 sub put_dom {
|
Line 853 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"); |
| } |
} |
| } |
} |
| |
|
|
Line 1516 sub clean_filename {
|
Line 1595 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 1570 sub userfileupload {
|
Line 1656 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 1580 sub userfileupload {
|
Line 1666 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 1590 sub userfileupload {
|
Line 1677 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 1635 sub finishuserfileupload {
|
Line 1724 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 1647 sub finishuserfileupload {
|
Line 1753 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 2069 sub get_course_adv_roles {
|
Line 2175 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)) { |
|
Line 4349 sub courselog_query {
|
Line 4460 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 6917 sub getCODE {
|
Line 7034 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 7426 sub hreflocation {
|
Line 7542 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 7439 sub current_machine_domains {
|
Line 7559 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 7579 sub goodbye {
|
Line 7704 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 |
| { |
{ |
| |
my $loaded; |
| my %domain; |
my %domain; |
| |
|
| 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); |
| |
|
| chomp($line); |
chomp($line); |
| my ($name,@elements) = split(/:/,$line,9); |
my ($name,@elements) = split(/:/,$line,9); |
| my %this_domain; |
my %this_domain; |
| foreach my $field ('description', 'auth_def', 'auth_arg_def', |
foreach my $field ('description', 'auth_def', 'auth_arg_def', |
| 'lang_def', 'city', 'longi', 'lati', |
'lang_def', 'city', 'longi', 'lati', |
|
Line 7605 BEGIN {
|
Line 7738 BEGIN {
|
| $this_domain{$field} = shift(@elements); |
$this_domain{$field} = shift(@elements); |
| } |
} |
| $domain{$name} = \%this_domain; |
$domain{$name} = \%this_domain; |
| # &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); |
|
| } |
} |
| } |
} |
| close ($fh); |
|
| |
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 { |
sub domain { |
| |
&load_domain_tab() if (!$loaded); |
| |
|
| my ($name,$what) = @_; |
my ($name,$what) = @_; |
| return if ( !exists($domain{$name}) ); |
return if ( !exists($domain{$name}) ); |
| |
|
|
Line 7627 BEGIN {
|
Line 7771 BEGIN {
|
| my %hostname; |
my %hostname; |
| my %hostdom; |
my %hostdom; |
| my %libserv; |
my %libserv; |
| open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
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 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 { |
sub is_library { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| return exists($libserv{$_[0]}); |
return exists($libserv{$_[0]}); |
| } |
} |
| |
|
| sub all_library { |
sub all_library { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| return %libserv; |
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 7683 BEGIN {
|
Line 7847 BEGIN {
|
| } |
} |
| |
|
| 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; |
|
Line 7696 BEGIN {
|
Line 7864 BEGIN {
|
| |
|
| { |
{ |
| my %iphost; |
my %iphost; |
| |
my %name_to_ip; |
| |
my %lonid_to_ip; |
| sub get_hosts_from_ip { |
sub get_hosts_from_ip { |
| my ($ip) = @_; |
my ($ip) = @_; |
| my %iphosts = &get_iphost(); |
my %iphosts = &get_iphost(); |
|
Line 7704 BEGIN {
|
Line 7874 BEGIN {
|
| } |
} |
| return; |
return; |
| } |
} |
| |
|
| |
sub get_host_ip { |
| |
my ($lonid) = @_; |
| |
if (exists($lonid_to_ip{$lonid})) { |
| |
return $lonid_to_ip{$lonid}; |
| |
} |
| |
my $name=&hostname($lonid); |
| |
my $ip = gethostbyname($name); |
| |
return if (!$ip || length($ip) ne 4); |
| |
$ip=inet_ntoa($ip); |
| |
$name_to_ip{$name} = $ip; |
| |
$lonid_to_ip{$lonid} = $ip; |
| |
return $ip; |
| |
} |
| |
|
| sub get_iphost { |
sub get_iphost { |
| if (%iphost) { return %iphost; } |
if (%iphost) { return %iphost; } |
| my %name_to_ip; |
|
| my %hostname = &all_hostnames(); |
my %hostname = &all_hostnames(); |
| foreach my $id (keys(%hostname)) { |
foreach my $id (keys(%hostname)) { |
| my $name=$hostname{$id}; |
my $name=$hostname{$id}; |
|
Line 7723 BEGIN {
|
Line 7906 BEGIN {
|
| } else { |
} else { |
| $ip = $name_to_ip{$name}; |
$ip = $name_to_ip{$name}; |
| } |
} |
| |
$lonid_to_ip{$id} = $ip; |
| push(@{$iphost{$ip}},$id); |
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 8060 X<userenvironment()>
|
Line 8254 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 8089 explanation of a user role term
|
Line 8293 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 8523 critical subroutine
|
Line 8729 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