--- loncom/lonnet/perl/lonnet.pm 2009/02/05 14:56:55 1.984 +++ loncom/lonnet/perl/lonnet.pm 2009/02/18 06:54:22 1.987 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.984 2009/02/05 14:56:55 neumanie Exp $ +# $Id: lonnet.pm,v 1.987 2009/02/18 06:54:22 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -74,6 +74,7 @@ use strict; use LWP::UserAgent(); use HTTP::Date; use Image::Magick; +use IO::Socket; # use Date::Parse; use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir @@ -150,7 +151,8 @@ sub logthis { my $now=time; my $local=localtime($now); 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); } return 1; @@ -526,7 +528,7 @@ sub appenv { # ----------------------------------------------------- Delete from Environment sub delenv { - my $delthis=shift; + my ($delthis,$regexp) = @_; if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { &logthis("WARNING: ". "Attempt to delete from environment ".$delthis); @@ -539,10 +541,17 @@ sub delenv { tie(my %disk_env,'GDBM_File',$env{'user.environment'}, (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { foreach my $key (keys(%disk_env)) { - if ($key=~/^\Q$delthis\E/) { - delete($env{$key}); - delete($disk_env{$key}); - } + if ($regexp) { + if ($key=~/^$delthis/) { + delete($env{$key}); + delete($disk_env{$key}); + } + } else { + if ($key=~/^\Q$delthis\E/) { + delete($env{$key}); + delete($disk_env{$key}); + } + } } untie(%disk_env); } @@ -1259,7 +1268,7 @@ sub get_domain_defaults { $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'}; $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; - $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'} + $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; } else { $domdefaults{'lang_def'} = &domain($domain,'lang_def'); $domdefaults{'auth_def'} = &domain($domain,'auth_def'); @@ -1278,6 +1287,11 @@ 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, $cachetime); return %domdefaults; @@ -4427,13 +4441,23 @@ sub is_portfolio_file { } sub usertools_access { - my ($uname,$udom,$tool,$action) = @_; - my $access; - my %tools = ( - aboutme => 1, - blog => 1, - portfolio => 1, - ); + my ($uname,$udom,$tool,$action,$context) = @_; + my ($access,%tools); + if ($context eq '') { + $context = 'tools'; + } + if ($context eq 'requestcourses') { + %tools = ( + official => 1, + unofficial => 1, + ); + } else { + %tools = ( + aboutme => 1, + blog => 1, + portfolio => 1, + ); + } return if (!defined($tools{$tool})); if ((!defined($udom)) || (!defined($uname))) { @@ -4443,18 +4467,23 @@ sub usertools_access { if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { 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); - if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { - $toolstatus = $env{'environment.tools.'.$tool}; + if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && + ($action ne 'reload')) { + $toolstatus = $env{'environment.'.$context.'.'.$tool}; $inststatus = $env{'environment.inststatus'}; } else { - my %userenv = &userenvironment($udom,$uname,'tools.'.$tool); - $toolstatus = $userenv{'tools.'.$tool}; + my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool); + $toolstatus = $userenv{$context.'.'.$tool}; $inststatus = $userenv{'inststatus'}; } @@ -4510,7 +4539,11 @@ sub usertools_access { } } } else { - $access = 1; + if ($context eq 'tools') { + $access = 1; + } else { + $access = 0; + } return $access; } } @@ -8986,6 +9019,23 @@ 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 { # ----------------------------------- Read loncapa.conf and loncapa_apache.conf @@ -9265,9 +9315,11 @@ in the user's environment.db and in %env =item * X -B: removes all items from the session -environment file that matches the regular expression in $regexp. The -values are also delted from the current processes %env. +B: removes all items from the session +environment file that begin with $delthis. If the +optional second arg - $regexp - is true, $delthis is treated as a +regular expression, otherwise \Q$delthis\E is used. +The values are also deleted from the current processes %env. =item * get_env_multiple($name) @@ -9875,8 +9927,15 @@ dirlist($uri) : return directory list ba 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 + =head2 Apache Request =over 4