--- loncom/lonnet/perl/lonnet.pm 2008/12/08 23:00:47 1.976
+++ loncom/lonnet/perl/lonnet.pm 2009/05/06 12:13:26 1.996
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.976 2008/12/08 23:00:47 raeburn Exp $
+# $Id: lonnet.pm,v 1.996 2009/05/06 12:13:26 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -73,7 +73,8 @@ package Apache::lonnet;
use strict;
use LWP::UserAgent();
use HTTP::Date;
-# use Date::Parse;
+use Image::Magick;
+
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
$_64bit %env %protocol);
@@ -97,6 +98,8 @@ use LONCAPA::Configuration;
my $readit;
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;
our @ISA = qw (Exporter);
@@ -146,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;
@@ -177,6 +181,47 @@ sub create_connection {
return 0;
}
+sub get_server_timezone {
+ my ($cnum,$cdom) = @_;
+ my $home=&homeserver($cnum,$cdom);
+ if ($home ne 'no_host') {
+ my $cachetime = 24*3600;
+ my ($timezone,$cached)=&is_cached_new('servertimezone',$home);
+ if (defined($cached)) {
+ return $timezone;
+ } else {
+ my $timezone = &reply('servertimezone',$home);
+ return &do_cache_new('servertimezone',$home,$timezone,$cachetime);
+ }
+ }
+}
+
+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 {
@@ -508,7 +553,7 @@ sub appenv {
# ----------------------------------------------------- Delete from Environment
sub delenv {
- my $delthis=shift;
+ my ($delthis,$regexp) = @_;
if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
&logthis("<font color=\"blue\">WARNING: ".
"Attempt to delete from environment ".$delthis);
@@ -521,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=~/^$delthis/) {
- 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);
}
@@ -978,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);
}
@@ -1227,7 +1286,6 @@ sub inst_userrules {
sub get_domain_defaults {
my ($domain) = @_;
my $cachetime = 60*60*24;
- my ($defauthtype,$defautharg,$deflang,%deftools);
my ($result,$cached)=&is_cached_new('domdefaults',$domain);
if (defined($cached)) {
if (ref($result) eq 'HASH') {
@@ -1236,11 +1294,14 @@ 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'};
$domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
+ $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
+ $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
} else {
$domdefaults{'lang_def'} = &domain($domain,'lang_def');
$domdefaults{'auth_def'} = &domain($domain,'auth_def');
@@ -1259,6 +1320,16 @@ sub get_domain_defaults {
}
}
}
+ if (ref($domconfig{'requestcourses'}) eq 'HASH') {
+ foreach my $item ('official','unofficial') {
+ $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;
@@ -1787,7 +1858,7 @@ sub ssi_body {
}
my $output='';
my $response;
- if ($filelink=~/^http\:/) {
+ if ($filelink=~/^https?\:/) {
($output,$response)=&externalssi($filelink);
} else {
($output,$response)=&ssi($filelink,%form);
@@ -2010,6 +2081,32 @@ sub clean_filename {
$fname=~s/\.(\d+)(?=\.)/_$1/g;
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
# input: $formname - the contents of the file are in $env{"form.$formname"}
@@ -2069,9 +2166,12 @@ sub userfileupload {
close($fh);
return $fullpath.'/'.$fname;
}
-
+ if ($subdir eq 'scantron') {
+ $fname = 'scantron_orig_'.$fname;
+ } else {
# Create the directory if not present
- $fname="$subdir/$fname";
+ $fname="$subdir/$fname";
+ }
if ($coursedoc) {
my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
@@ -2110,6 +2210,7 @@ sub finishuserfileupload {
$thumbwidth,$thumbheight) = @_;
my $path=$docudom.'/'.$docuname.'/';
my $filepath=$perlvar{'lonDocRoot'};
+
my ($fnamepath,$file,$fetchthumb);
$file=$fname;
if ($fname=~m|/|) {
@@ -2124,6 +2225,7 @@ sub finishuserfileupload {
mkdir($filepath,0777);
}
}
+
# Save the file
{
if (!open(FH,'>'.$filepath.'/'.$file)) {
@@ -2137,6 +2239,11 @@ sub finishuserfileupload {
return '/adm/notfound.html';
}
close(FH);
+ if($upload_photo_form==1)
+ {
+ resizeImage($filepath.'/'.$file);
+ $upload_photo_form = 0;
+ }
}
if ($parser eq 'parse') {
my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles,
@@ -2158,7 +2265,7 @@ sub finishuserfileupload {
# Notify homeserver to grep it
#
- my $docuhome=&homeserver($docuname,$docudom);
+ my $docuhome=&homeserver($docuname,$docudom);
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
if ($fetchresult eq 'ok') {
if ($fetchthumb) {
@@ -2290,21 +2397,21 @@ sub add_filetype {
}
sub removeuploadedurl {
- my ($url)=@_;
- my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
+ my ($url)=@_;
+ my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
return &removeuserfile($uname,$udom,$fname);
}
sub removeuserfile {
my ($docuname,$docudom,$fname)=@_;
- my $home=&homeserver($docuname,$docudom);
+ my $home=&homeserver($docuname,$docudom);
my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
- if ($result eq 'ok') {
+ if ($result eq 'ok') {
if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
my $metafile = $fname.'.meta';
my $metaresult = &removeuserfile($docuname,$docudom,$metafile);
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 =
&update_portfolio_table($docuname,$docudom,$file,
'portfolio_metadata',$group,
@@ -2602,6 +2709,9 @@ sub courserolelog {
$storehash{'section'} = $sec;
}
&instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);
+ if (($trole ne 'st') || ($sec ne '')) {
+ &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);
+ }
}
}
return;
@@ -2611,6 +2721,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 !~ /:/) {
@@ -2641,7 +2752,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;
@@ -3775,6 +3886,67 @@ sub set_userprivs {
return ($author,$adv);
}
+sub role_status {
+ my ($rolekey,$then,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
+ my @pwhere = ();
+ if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
+ (undef,undef,$$role,@pwhere)=split(/\./,$rolekey);
+ unless (!defined($$role) || $$role eq '') {
+ $$where=join('.',@pwhere);
+ $$trolecode=$$role.'.'.$$where;
+ ($$tstart,$$tend)=split(/\./,$env{$rolekey});
+ $$tstatus='is';
+ if ($$tstart && $$tstart>$then) {
+ $$tstatus='future';
+ if ($$tstart<$now) { $$tstatus='will'; }
+ }
+ if ($$tend) {
+ if ($$tend<$then) {
+ $$tstatus='expired';
+ } elsif ($$tend<$now) {
+ $$tstatus='will_not';
+ }
+ }
+ }
+ }
+}
+
+sub check_adhoc_privs {
+ my ($cdom,$cnum,$then,$now,$checkrole) = @_;
+ my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
+ if ($env{$cckey}) {
+ my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
+ &role_status($cckey,$then,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
+ unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {
+ &set_adhoc_privileges($cdom,$cnum,$checkrole);
+ }
+ } else {
+ &set_adhoc_privileges($cdom,$cnum,$checkrole);
+ }
+}
+
+sub set_adhoc_privileges {
+# role can be cc or ca
+ my ($dcdom,$pickedcourse,$role) = @_;
+ my $area = '/'.$dcdom.'/'.$pickedcourse;
+ my $spec = $role.'.'.$area;
+ my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
+ $env{'user.name'});
+ my %ccrole = ();
+ &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);
+ my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);
+ &appenv(\%userroles,[$role,'cm']);
+ &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
+ &appenv( {'request.role' => $spec,
+ 'request.role.domain' => $dcdom,
+ 'request.course.sec' => ''
+ }
+ );
+ my $tadv=0;
+ if (&allowed('adv') eq 'F') { $tadv=1; }
+ &appenv({'request.role.adv' => $tadv});
+}
+
# --------------------------------------------------------------- get interface
sub get {
@@ -3810,11 +3982,11 @@ sub del {
foreach my $item (@$storearr) {
$items.=&escape($item).'&';
}
+
$items=~s/\&$//;
if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
-
return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
}
@@ -4375,13 +4547,23 @@ sub is_portfolio_file {
}
sub usertools_access {
- my ($uname,$udom,$tool) = @_;
- 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))) {
@@ -4389,20 +4571,25 @@ sub usertools_access {
$uname = $env{'user.name'};
}
- my $hashid=$uname.':'.$udom;
- my ($result,$cached) = &is_cached_new('usertools.'.$tool,$hashid);
- if (defined($cached)) {
- return $result;
+ if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
+ if ($action ne 'reload') {
+ 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'};
}
@@ -4412,7 +4599,6 @@ sub usertools_access {
} else {
$access = 0;
}
- &do_cache_new('usertools.'.$tool,$hashid,$access,600);
return $access;
}
@@ -4426,7 +4612,6 @@ sub usertools_access {
} else {
$access = 0;
}
- &do_cache_new('usertools.'.$tool,$hashid,$access,600);
return $access;
}
}
@@ -4447,7 +4632,6 @@ sub usertools_access {
} elsif ($hasnoaccess) {
$access = 0;
}
- &do_cache_new('usertools.'.$tool,$hashid,$access,600);
return $access;
}
} else {
@@ -4457,13 +4641,15 @@ sub usertools_access {
} elsif ($domdef{$tool}{'default'} == 0) {
$access = 0;
}
- &do_cache_new('usertools.'.$tool,$hashid,$access,600);
return $access;
}
}
} else {
- $access = 1;
- &do_cache_new('usertools.'.$tool,$hashid,$access,600);
+ if ($context eq 'tools') {
+ $access = 1;
+ } else {
+ $access = 0;
+ }
return $access;
}
}
@@ -5588,16 +5774,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',
@@ -5818,7 +6007,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);
@@ -5840,7 +6043,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';
@@ -5849,7 +6052,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
@@ -8306,7 +8509,10 @@ sub repcopy_userfile {
if (-e $transferfile) { return 'ok'; }
my $request;
$uri=~s/^\///;
- $request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);
+ my $homeserver = &homeserver($cnum,$cdom);
+ my $protocol = $protocol{$homeserver};
+ $protocol = 'http' if ($protocol ne 'https');
+ $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri);
my $response=$ua->request($request,$transferfile);
# did it work?
if ($response->is_error()) {
@@ -8321,7 +8527,7 @@ sub repcopy_userfile {
sub tokenwrapper {
my $uri=shift;
- $uri=~s|^http\://([^/]+)||;
+ $uri=~s|^https?\://([^/]+)||;
$uri=~s|^/||;
$env{'user.environment'}=~/\/([^\/]+)\.id/;
my $token=$1;
@@ -8329,7 +8535,10 @@ sub tokenwrapper {
if ($udom && $uname && $file) {
$file=~s|(\?\.*)*$||;
&appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
- return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.
+ my $homeserver = &homeserver($uname,$udom);
+ my $protocol = $protocol{$homeserver};
+ $protocol = 'http' if ($protocol ne 'https');
+ return $protocol.'://'.&hostname($homeserver).'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};
} else {
@@ -8344,7 +8553,10 @@ sub tokenwrapper {
sub getuploaded {
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
$uri=~s/^\///;
- $uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri;
+ my $homeserver = &homeserver($cnum,$cdom);
+ my $protocol = $protocol{$homeserver};
+ $protocol = 'http' if ($protocol ne 'https');
+ $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;
my $ua=new LWP::UserAgent;
my $request=new HTTP::Request($reqtype,$uri);
my $response=$ua->request($request);
@@ -8426,7 +8638,7 @@ sub filelocation {
sub hreflocation {
my ($dir,$file)=@_;
- unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
+ unless (($file=~m-^https?\://-i) || ($file=~m-^/-)) {
$file=filelocation($dir,$file);
} elsif ($file=~m-^/adm/-) {
$file=~s-^/adm/wrapper/-/-;
@@ -8622,14 +8834,19 @@ sub get_dns {
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
foreach my $dns (<$config>) {
next if ($dns !~ /^\^(\S*)/x);
- $alldns{$1} = 1;
+ my $line = $1;
+ my ($host,$protocol) = split(/:/,$line);
+ if ($protocol ne 'https') {
+ $protocol = 'http';
+ }
+ $alldns{$host} = $protocol;
}
while (%alldns) {
my ($dns) = keys(%alldns);
- delete($alldns{$dns});
my $ua=new LWP::UserAgent;
- my $request=new HTTP::Request('GET',"http://$dns$url");
+ my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
my $response=$ua->request($request);
+ delete($alldns{$dns});
next if ($response->is_error());
my @content = split("\n",$response->content);
&Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60);
@@ -8923,6 +9140,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 {
@@ -9204,9 +9446,11 @@ in the user's environment.db and in %env
=item *
X<delenv()>
-B<delenv($regexp)>: 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<delenv($delthis,$regexp)>: 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)
@@ -9303,9 +9547,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) :
@@ -9814,8 +10063,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