--- loncom/lonnet/perl/lonnet.pm 2009/02/08 20:28:52 1.985 +++ loncom/lonnet/perl/lonnet.pm 2009/04/11 14:47:51 1.993 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.985 2009/02/08 20:28:52 raeburn Exp $ +# $Id: lonnet.pm,v 1.993 2009/04/11 14:47:51 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -75,7 +75,6 @@ use LWP::UserAgent(); use HTTP::Date; use Image::Magick; -# use Date::Parse; use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $_64bit %env %protocol); @@ -150,7 +149,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; @@ -196,6 +196,33 @@ sub get_server_timezone { } } +sub get_server_loncaparev { + my ($dom,$lonhost) = @_; + if (defined($lonhost)) { + if (!defined(&hostname($lonhost))) { + undef($lonhost); + } + } + if (!defined($lonhost)) { + if (defined(&domain($dom,'primary'))) { + $lonhost=&domain($dom,'primary'); + if ($lonhost eq 'no_host') { + undef($lonhost); + } + } + } + if (defined($lonhost)) { + my $cachetime = 24*3600; + my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost); + if (defined($cached)) { + return $loncaparev; + } else { + my $loncaparev = &reply('serverloncaparev',$lonhost); + return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime); + } + } +} + # -------------------------------------------------- Non-critical communication sub subreply { my ($cmd,$server)=@_; @@ -526,7 +553,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 +566,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); } @@ -996,27 +1030,34 @@ sub put_dom { sub retrieve_inst_usertypes { my ($udom) = @_; my (%returnhash,@order); - if (defined(&domain($udom,'primary'))) { - my $uhome=&domain($udom,'primary'); - my $rep=&reply("inst_usertypes:$udom",$uhome); - if ($rep =~ /^(con_lost|error|no_such_host|refused)/) { - &logthis("get_dom failed - $rep returned from $uhome in domain: $udom"); - return (\%returnhash,\@order); - } - my ($hashitems,$orderitems) = split(/:/,$rep); - my @pairs=split(/\&/,$hashitems); - foreach my $item (@pairs) { - my ($key,$value)=split(/=/,$item,2); - $key = &unescape($key); - next if ($key =~ /^error: 2 /); - $returnhash{$key}=&thaw_unescape($value); - } - my @esc_order = split(/\&/,$orderitems); - foreach my $item (@esc_order) { - push(@order,&unescape($item)); - } + my %domdefs = &Apache::lonnet::get_domain_defaults($udom); + if ((ref($domdefs{'inststatustypes'}) eq 'HASH') && + (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) { + %returnhash = %{$domdefs{'inststatustypes'}}; + @order = @{$domdefs{'inststatusorder'}}; } else { - &logthis("get_dom failed - no primary domain server for $udom"); + if (defined(&domain($udom,'primary'))) { + my $uhome=&domain($udom,'primary'); + my $rep=&reply("inst_usertypes:$udom",$uhome); + if ($rep =~ /^(con_lost|error|no_such_host|refused)/) { + &logthis("get_dom failed - $rep returned from $uhome in domain: $udom"); + return (\%returnhash,\@order); + } + my ($hashitems,$orderitems) = split(/:/,$rep); + my @pairs=split(/\&/,$hashitems); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + $returnhash{$key}=&thaw_unescape($value); + } + my @esc_order = split(/\&/,$orderitems); + foreach my $item (@esc_order) { + push(@order,&unescape($item)); + } + } else { + &logthis("get_dom failed - no primary domain server for $udom"); + } } return (\%returnhash,\@order); } @@ -1253,7 +1294,8 @@ sub get_domain_defaults { } my %domdefaults; my %domconfig = - &Apache::lonnet::get_dom('configuration',['defaults','quotas'],$domain); + &Apache::lonnet::get_dom('configuration',['defaults','quotas', + 'requestcourses','inststatus'],$domain); if (ref($domconfig{'defaults'}) eq 'HASH') { $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; @@ -1283,6 +1325,11 @@ sub get_domain_defaults { $domdefaults{$item} = $domconfig{'requestcourses'}{$item}; } } + if (ref($domconfig{'inststatus'}) eq 'HASH') { + foreach my $item ('inststatustypes','inststatusorder') { + $domdefaults{$item} = $domconfig{'inststatus'}{$item}; + } + } &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, $cachetime); return %domdefaults; @@ -2668,6 +2715,7 @@ sub get_course_adv_roles { my ($cid,$codes) = @_; $cid=$env{'request.course.id'} unless (defined($cid)); my %coursehash=&coursedescription($cid); + my $crstype = &Apache::loncommon::course_type($cid); my %nothide=(); foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { if ($user !~ /:/) { @@ -2698,7 +2746,7 @@ sub get_course_adv_roles { $returnhash{$role}=$username.':'.$domain; } } else { - my $key=&plaintext($role); + my $key=&plaintext($role,$crstype); if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; } if ($returnhash{$key}) { $returnhash{$key}.=','.$username.':'.$domain; @@ -5659,16 +5707,19 @@ sub devalidate_getgroups_cache { # ------------------------------------------------------------------ Plain Text sub plaintext { - my ($short,$type,$cid) = @_; + my ($short,$type,$cid,$forcedefault) = @_; if ($short =~ /^cr/) { return (split('/',$short))[-1]; } if (!defined($cid)) { $cid = $env{'request.course.id'}; } - if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) { - return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short. - '.plaintext'}); + if (defined($cid) && ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '')) { + unless ($forcedefault) { + my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'}; + &Apache::lonlocal::mt_escape(\$roletext); + return &Apache::lonlocal::mt($roletext); + } } my %rolenames = ( Course => 'std', @@ -5889,7 +5940,21 @@ sub modifyuser { if ($email=~/\@/) { $names{'permanentemail'} = $email; } } if ($uid) { $names{'id'} = $uid; } - if (defined($inststatus)) { $names{'inststatus'} = $inststatus; } + if (defined($inststatus)) { + $names{'inststatus'} = ''; + my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom); + if (ref($usertypes) eq 'HASH') { + my @okstatuses; + foreach my $item (split(/:/,$inststatus)) { + if (defined($usertypes->{$item})) { + push(@okstatuses,$item); + } + } + if (@okstatuses) { + $names{'inststatus'} = join(':', map { &escape($_); } @okstatuses); + } + } + } my $reply = &put('environment', \%names, $udom,$uname); if ($reply ne 'ok') { return 'error: '.$reply; } my $sqlresult = &update_allusers_table($uname,$udom,\%names); @@ -5911,7 +5976,7 @@ sub modifyuser { sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid, - $selfenroll,$context)=@_; + $selfenroll,$context,$inststatus)=@_; if (!$cid) { unless ($cid=$env{'request.course.id'}) { return 'not_in_class'; @@ -5920,7 +5985,7 @@ sub modifystudent { # --------------------------------------------------------------- Make the user my $reply=&modifyuser ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, - $desiredhome,$email); + $desiredhome,$email,$inststatus); unless ($reply eq 'ok') { return $reply; } # This will cause &modify_student_enrollment to get the uid from the # students environment @@ -9008,6 +9073,31 @@ sub get_dns { return %iphost; } + + # + # Given a DNS returns the loncapa host name for that DNS + # + sub host_from_dns { + my ($dns) = @_; + my @hosts; + my $ip; + + if (exists($name_to_ip{$dns})) { + $ip = $name_to_ip{$dns}; + } + if (!$ip) { + $ip = gethostbyname($dns); # Initial translation to IP is in net order. + if (length($ip) == 4) { + $ip = &IO::Socket::inet_ntoa($ip); + } + } + if ($ip) { + @hosts = get_hosts_from_ip($ip); + return $hosts[0]; + } + return undef; + } + } BEGIN { @@ -9289,9 +9379,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) @@ -9388,9 +9480,14 @@ and course level =item * -plaintext($short) : return value in %prp hash (rolesplain.tab); plain text -explanation of a user role term - +plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash +(rolesplain.tab); plain text explanation of a user role term. +$type is Course (default) or Group. +If $forcedefault evaluates to true, text returned will be default +text for $type. Otherwise, if this is a course, the text returned +will be a custom name for the role (if defined in the course's +environment). If no custom name is defined the default is returned. + =item * get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) : @@ -9899,8 +9996,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