--- loncom/lonnet/perl/lonnet.pm 2004/11/27 17:23:08 1.571 +++ loncom/lonnet/perl/lonnet.pm 2005/02/10 22:26:38 1.598 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.571 2004/11/27 17:23:08 raeburn Exp $ +# $Id: lonnet.pm,v 1.598 2005/02/10 22:26:38 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -35,7 +35,7 @@ use HTTP::Headers; use HTTP::Date; # use Date::Parse; use vars -qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom +qw(%perlvar %hostname %homecache %badServerCache %iphost %spareid %hostdom %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache %courselogs %accesshash %userrolehash $processmarker $dumpcount %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %courseresdatacache @@ -157,22 +157,6 @@ sub reply { my ($cmd,$server)=@_; unless (defined($hostname{$server})) { return 'no_such_host'; } my $answer=subreply($cmd,$server); - if ($answer eq 'con_lost') { - #sleep 5; - #$answer=subreply($cmd,$server); - #if ($answer eq 'con_lost') { - # &logthis("Second attempt con_lost on $server"); - # my $peerfile="$perlvar{'lonSockDir'}/$server"; - # my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", - # Type => SOCK_STREAM, - # Timeout => 10) - # or return "con_lost"; - # &logthis("Killing socket"); - # print $client "close_connection_exit\n"; - #sleep 5; - # $answer=subreply($cmd,$server); - #} - } if (($answer=~/^refused/) || ($answer=~/^rejected/)) { &logthis("WARNING:". " $cmd to $server returned $answer"); @@ -220,11 +204,8 @@ sub critical { } my $answer=reply($cmd,$server); if ($answer eq 'con_lost') { - my $pingreply=reply('ping',$server); &reconlonc("$perlvar{'lonSockDir'}/$server"); - my $pongreply=reply('pong',$server); - &logthis("Ping/Pong for $server: $pingreply/$pongreply"); - $answer=reply($cmd,$server); + my $answer=reply($cmd,$server); if ($answer eq 'con_lost') { my $now=time; my $middlename=$cmd; @@ -1406,13 +1387,13 @@ sub finishuserfileupload { } # Save the file { - #&Apache::lonnet::logthis("Saving to $filepath $file"); open(FH,'>'.$filepath.'/'.$file); print FH $ENV{'form.'.$formname}; close(FH); } # Notify homeserver to grep it # + &Apache::lonnet::logthis("fetching ".$path.$file); my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); if ($fetchresult eq 'ok') { # @@ -1588,11 +1569,23 @@ sub courseacclog { my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'}; if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) { $what.=':POST'; + # FIXME: Probably ought to escape things.... foreach (keys %ENV) { if ($_=~/^form\.(.*)/) { $what.=':'.$1.'='.$ENV{$_}; } } + } elsif ($fnsymb =~ m:^/adm/searchcat:) { + # FIXME: We should not be depending on a form parameter that someone + # editing lonsearchcat.pm might change in the future. + if ($ENV{'form.phase'} eq 'course_search') { + $what.= ':POST'; + # FIXME: Probably ought to escape things.... + foreach my $element ('courseexp','crsfulltext','crsrelated', + 'crsdiscuss') { + $what.=':'.$element.'='.$ENV{'form.'.$element}; + } + } } &courselog($what); } @@ -1644,6 +1637,7 @@ sub get_course_adv_roles { if (($tend) && ($tend<$now)) { next; } if (($tstart) && ($now<$tstart)) { next; } my ($role,$username,$domain,$section)=split(/\:/,$_); + if ($username eq '' || $domain eq '') { next; } if ((&privileged($username,$domain)) && (!$nothide{$username.':'.$domain})) { next; } my $key=&plaintext($role); @@ -1745,19 +1739,27 @@ sub get_first_access { my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); if ($argsymb) { $symb=$argsymb; } my ($map,$id,$res)=&decode_symb($symb); - if ($type eq 'map') { $res=$map; } - my %times=&get('firstaccesstimes',[$res],$udom,$uname); - return $times{$res}; + if ($type eq 'map') { + $res=&symbread($map); + } else { + $res=$symb; + } + my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname); + return $times{"$courseid\0$res"}; } sub set_first_access { my ($type)=@_; my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); my ($map,$id,$res)=&decode_symb($symb); - if ($type eq 'map') { $res=$map; } - my $firstaccess=&get_first_access($type); + if ($type eq 'map') { + $res=&symbread($map); + } else { + $res=$symb; + } + my $firstaccess=&get_first_access($type,$symb); if (!$firstaccess) { - return &put('firstaccesstimes',{$res=>time},$udom,$uname); + return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname); } return 'already_set'; } @@ -1815,7 +1817,7 @@ sub checkin { my $now=time; my ($ta,$tb,$lonhost)=split(/\*/,$token); $lonhost=~tr/A-Z/a-z/; - my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb; + my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb; $dtoken=~s/\W/\_/g; my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); @@ -2098,9 +2100,11 @@ sub tmpreset { $namespace=~s/\//\_/g; $namespace=~s/\W//g; - #FIXME needs to do something for /pub resources if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } + if ($domain eq 'public' && $stuname eq 'public') { + $stuname=$ENV{'REMOTE_ADDR'}; + } my $path=$perlvar{'lonDaemons'}.'/tmp'; my %hash; if (tie(%hash,'GDBM_File', @@ -2133,9 +2137,11 @@ sub tmpstore { } $namespace=~s/\//\_/g; $namespace=~s/\W//g; -#FIXME needs to do something for /pub resources if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } + if ($domain eq 'public' && $stuname eq 'public') { + $stuname=$ENV{'REMOTE_ADDR'}; + } my $now=time; my %hash; my $path=$perlvar{'lonDaemons'}.'/tmp'; @@ -2147,7 +2153,7 @@ sub tmpstore { my $allkeys=''; foreach my $key (keys(%$storehash)) { $allkeys.=$key.':'; - $hash{"$version:$symb:$key"}=$$storehash{$key}; + $hash{"$version:$symb:$key"}=&freeze_escape($$storehash{$key}); } $hash{"$version:$symb:timestamp"}=$now; $allkeys.='timestamp'; @@ -2174,10 +2180,12 @@ sub tmprestore { $symb=escape($symb); if (!$namespace) { $namespace=$ENV{'request.state'}; } - #FIXME needs to do something for /pub resources + if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } - + if ($domain eq 'public' && $stuname eq 'public') { + $stuname=$ENV{'REMOTE_ADDR'}; + } my %returnhash; $namespace=~s/\//\_/g; $namespace=~s/\W//g; @@ -2195,8 +2203,8 @@ sub tmprestore { my $key; $returnhash{"$scope:keys"}=$vkeys; foreach $key (@keys) { - $returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"}; - $returnhash{"$key"}=$hash{"$scope:$symb:$key"}; + $returnhash{"$scope:$key"}=&thaw_unescape($hash{"$scope:$symb:$key"}); + $returnhash{"$key"}=&thaw_unescape($hash{"$scope:$symb:$key"}); } } if (!(untie(%hash))) { @@ -2237,7 +2245,7 @@ sub store { my $namevalue=''; foreach (keys %$storehash) { - $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; + $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; } $namevalue=~s/\&$//; &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); @@ -2273,7 +2281,7 @@ sub cstore { my $namevalue=''; foreach (keys %$storehash) { - $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; + $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; } $namevalue=~s/\&$//; &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); @@ -2307,7 +2315,7 @@ sub restore { my %returnhash=(); foreach (split(/\&/,$answer)) { my ($name,$value)=split(/\=/,$_); - $returnhash{&unescape($name)}=&unescape($value); + $returnhash{&unescape($name)}=&thaw_unescape($value); } my $version; for ($version=1;$version<=$returnhash{'version'};$version++) { @@ -2363,7 +2371,7 @@ sub privileged { my $now=time; if ($rolesdump ne '') { foreach (split(/&/,$rolesdump)) { - if ($_!~/^rolesdef\&/) { + if ($_!~/^rolesdef_/) { my ($area,$role)=split(/=/,$_); $area=~s/\_\w\w$//; my ($trole,$tend,$tstart)=split(/_/,$role); @@ -2395,11 +2403,18 @@ sub rolesinit { if ($rolesdump ne '') { foreach (split(/&/,$rolesdump)) { - if ($_!~/^rolesdef\&/) { + if ($_!~/^rolesdef_/) { my ($area,$role)=split(/=/,$_); - $area=~s/\_\w\w$//; - my ($trole,$tend,$tstart)=split(/_/,$role); - $userroles.=&set_arearole($trole,$area,$tstart,$tend); + $area=~s/\_\w\w$//; + + my ($trole,$tend,$tstart); + if ($role=~/^cr/) { + ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|); + ($tend,$tstart)=split('_',$trest); + } else { + ($trole,$tend,$tstart)=split(/_/,$role); + } + $userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username); if (($tend!=0) && ($tend<$now)) { $trole=''; } if (($tstart!=0) && ($tstart>$now)) { $trole=''; } if (($area ne '') && ($trole ne '')) { @@ -2691,7 +2706,7 @@ sub putstore { my $key = $1.':keys:'.$2; $allitems{$key} .= $3.':'; } - $items.=$_.'='.&escape($$storehash{$_}).'&'; + $items.=$_.'='.&freeze_escape($$storehash{$_}).'&'; } foreach (keys %allitems) { $allitems{$_} =~ s/\:$//; @@ -2776,7 +2791,7 @@ sub customaccess { # ------------------------------------------------- Check for a user privilege sub allowed { - my ($priv,$uri)=@_; + my ($priv,$uri,$symb)=@_; $uri=&deversion($uri); my $orguri=$uri; $uri=&declutter($uri); @@ -3057,7 +3072,7 @@ sub allowed { if ($thisallowed=~/X/) { if ($ENV{'acc.randomout'}) { - my $symb=&symbread($uri,1); + if (!$symb) { $symb=&symbread($uri,1); } if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) { return ''; } @@ -3359,11 +3374,18 @@ sub auto_instcode_format { my $courses = ''; my $homeserver; if ($caller eq 'global') { - $homeserver = $perlvar{'lonHostID'}; + foreach my $tryserver (keys %libserv) { + if ($hostdom{$tryserver} eq $codedom) { + $homeserver = $tryserver; + last; + } + } + if (($ENV{'user.name'}) && ($ENV{'user.domain'} eq $codedom)) { + $homeserver = &homeserver($ENV{'user.name'},$codedom); + } } else { $homeserver = &homeserver($caller,$codedom); } - my $host=$hostname{$homeserver}; foreach (keys %{$instcodes}) { $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&'; } @@ -3554,9 +3576,12 @@ sub modifyuser { if (defined($middle)) { $names{'middlename'} = $middle; } if ($last) { $names{'lastname'} = $last; } if (defined($gene)) { $names{'generation'} = $gene; } - if ($email) { $names{'notification'} = $email; - $names{'critnotification'} = $email; } - + if ($email) { + $email=~s/[^\w\@\.\-\,]//gs; + if ($email=~/\@/) { $names{'notification'} = $email; + $names{'critnotification'} = $email; + $names{'permanentemail'} = $email; } + } my $reply = &put('environment', \%names, $udom,$uname); if ($reply ne 'ok') { return 'error: '.$reply; } &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. @@ -3812,6 +3837,75 @@ sub mark_as_readonly { return; } +# ------------------------------------------------------------Save Selected Files + +sub save_selected_files { + my ($user, $path, @files) = @_; + my $filename = $user."savedfiles"; + my @other_files = &files_not_in_path($user, $path); + open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + foreach my $file (@files) { + print (OUT $ENV{'form.currentpath'}.$file."\n"); + } + foreach my $file (@other_files) { + print (OUT $file."\n"); + } + close (OUT); + return 'ok'; +} + +sub clear_selected_files { + my ($user) = @_; + my $filename = $user."savedfiles"; + open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + print (OUT undef); + close (OUT); + return ("ok"); +} + +sub files_in_path { + my ($user, $path) = @_; + my $filename = $user."savedfiles"; + my %return_files; + open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + while (my $line_in = ) { + chomp ($line_in); + my @paths_and_file = split (m!/!, $line_in); + my $file_part = pop (@paths_and_file); + my $path_part = join ('/', @paths_and_file); + $path_part.='/'; + my $path_and_file = $path_part.$file_part; + if ($path_part eq $path) { + $return_files{$file_part}= 'selected'; + } + } + close (IN); + return (\%return_files); +} + +# called in portfolio select mode, to show files selected NOT in current directory +sub files_not_in_path { + my ($user, $path) = @_; + my $filename = $user."savedfiles"; + my @return_files; + my $path_part; + open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + while () { + #ok, I know it's clunky, but I want it to work + my @paths_and_file = split m!/!, $_; + my $file_part = pop (@paths_and_file); + chomp ($file_part); + my $path_part = join ('/', @paths_and_file); + $path_part .= '/'; + my $path_and_file = $path_part.$file_part; + if ($path_part ne $path) { + push (@return_files, ($path_and_file)); + } + } + close (OUT); + return (@return_files); +} + #--------------------------------------------------------------Get Marked as Read Only sub get_marked_as_readonly { @@ -3831,7 +3925,25 @@ sub get_marked_as_readonly { } return @readonly_files; } +#-----------------------------------------------------------Get Marked as Read Only Hash +sub get_marked_as_readonly_hash { + my ($domain,$user,$what) = @_; + my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); + my %readonly_files; + while (my ($file_name,$value) = each(%current_permissions)) { + if (ref($value) eq "ARRAY"){ + foreach my $stored_what (@{$value}) { + if ($stored_what eq $what) { + $readonly_files{$file_name} = 'locked'; + } elsif (!defined($what)) { + $readonly_files{$file_name} = 'locked'; + } + } + } + } + return %readonly_files; +} # ------------------------------------------------------------ Unmark as Read Only sub unmark_as_readonly { @@ -4201,6 +4313,7 @@ sub EXT { if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { if (!$symbparm) { $symbparm=&symbread(); } } + my ($courselevelm,$courselevel); if ($symbparm && defined($courseid) && $courseid eq $ENV{'request.course.id'}) { @@ -4228,9 +4341,9 @@ sub EXT { my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; - my $courselevel=$courseid.'.'.$spacequalifierrest; + $courselevel=$courseid.'.'.$spacequalifierrest; my $courselevelr=$courseid.'.'.$symbparm; - my $courselevelm=$courseid.'.'.$mapparm; + $courselevelm=$courseid.'.'.$mapparm; # ----------------------------------------------------------- first, check user #most student don\'t have any data set, check if there is some data @@ -4266,13 +4379,12 @@ sub EXT { } } -# -------------------------------------------------------- second, check course +# ------------------------------------------------ second, check some of course my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, $ENV{'course.'.$courseid.'.domain'}, ($seclevelr,$seclevelm,$seclevel, - $courselevelr,$courselevelm, - $courselevel)); + $courselevelr)); if (defined($coursereply)) { return $coursereply; } # ------------------------------------------------------ third, check map parms @@ -4286,7 +4398,7 @@ sub EXT { } if ($thisparm) { return $thisparm; } } -# --------------------------------------------- last, look in resource metadata +# ------------------------------------------ fourth, look in resource metadata $spacequalifierrest=~s/\./\_/; my $filename; @@ -4301,6 +4413,14 @@ sub EXT { $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); if (defined($metadata)) { return $metadata; } +# ---------------------------------------------- fourth, look in rest pf course + if ($symbparm && defined($courseid) && + $courseid eq $ENV{'request.course.id'}) { + my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, + $ENV{'course.'.$courseid.'.domain'}, + ($courselevelm,$courselevel)); + if (defined($coursereply)) { return $coursereply; } + } # ------------------------------------------------------------------ Cascade up unless ($space eq '0') { my @parts=split(/_/,$space); @@ -4343,6 +4463,7 @@ sub packages_tab_default { if (defined($packagetab{"$pack_type&$name&default"})) { return $packagetab{"$pack_type&$name&default"}; } + if ($pack_type eq 'part') { $pack_part='0'; } if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) { return $packagetab{$pack_type."_".$pack_part."&$name&default"}; } @@ -4624,7 +4745,9 @@ sub gettitle { my $symb=&symbread($urlsymb); if ($symb) { my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600); - if (defined($cached)) { return $result; } + if (defined($cached)) { + return $result; + } my ($map,$resid,$url)=&decode_symb($symb); my $title=''; my %bighash; @@ -4700,8 +4823,11 @@ sub symbverify { if ( &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) eq $symb) { - $okay=1; - } + if (($ENV{'request.role.adv'}) || + $bighash{'encrypted_'.$_} eq $ENV{'request.enc'}) { + $okay=1; + } + } } } untie(%bighash); @@ -4896,8 +5022,25 @@ sub numval2 { return int($total); } +sub numval3 { + use integer; + my $txt=shift; + $txt=~tr/A-J/0-9/; + $txt=~tr/a-j/0-9/; + $txt=~tr/K-T/0-9/; + $txt=~tr/k-t/0-9/; + $txt=~tr/U-Z/0-5/; + $txt=~tr/u-z/0-5/; + $txt=~s/\D//g; + my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt); + my $total; + foreach my $val (@txts) { $total+=$val; } + if ($_64bit) { $total=(($total<<32)>>32); } + return $total; +} + sub latest_rnd_algorithm_id { - return '64bit3'; + return '64bit4'; } sub get_rand_alg { @@ -4936,7 +5079,13 @@ sub rndseed { if (!$username) { $username=$wusername } my $which=&get_rand_alg(); if (defined(&getCODE())) { - return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); + if ($which eq '64bit4') { + return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username); + } else { + return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); + } + } elsif ($which eq '64bit4') { + return &rndseed_64bit4($symb,$courseid,$domain,$username); } elsif ($which eq '64bit3') { return &rndseed_64bit3($symb,$courseid,$domain,$username); } elsif ($which eq '64bit2') { @@ -5033,6 +5182,30 @@ sub rndseed_64bit3 { } } +sub rndseed_64bit4 { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + # strings need to be an even # of cahracters long, it it is odd the + # last characters gets thrown away + my $symbchck=unpack("%32S*",$symb.' ') << 21; + my $symbseed=numval3($symb) << 10; + my $namechck=unpack("%32S*",$username.' '); + + my $nameseed=numval3($username) << 21; + my $domainseed=unpack("%32S*",$domain.' ') << 10; + my $courseseed=unpack("%32S*",$courseid.' '); + + my $num1=$symbchck+$symbseed+$namechck; + my $num2=$nameseed+$domainseed+$courseseed; + #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit"); + if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } + + return "$num1:$num2"; + } +} + sub rndseed_CODE_64bit { my ($symb,$courseid,$domain,$username)=@_; { @@ -5052,6 +5225,25 @@ sub rndseed_CODE_64bit { } } +sub rndseed_CODE_64bit4 { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + my $symbchck=unpack("%32S*",$symb.' ') << 16; + my $symbseed=numval3($symb); + my $CODEchck=unpack("%32S*",&getCODE().' ') << 16; + my $CODEseed=numval3(&getCODE()); + my $courseseed=unpack("%32S*",$courseid.' '); + my $num1=$symbseed+$CODEchck; + my $num2=$CODEseed+$courseseed+$symbchck; + #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); + if ($_64bit) { $num1=(($num1<<32)>>32); } + if ($_64bit) { $num2=(($num2<<32)>>32); } + return "$num1:$num2"; + } +} + sub setup_random_from_rndseed { my ($rndseed)=@_; if ($rndseed =~/([,:])/) { @@ -5258,39 +5450,42 @@ sub readfile { } sub filelocation { - my ($dir,$file) = @_; - my $location; - $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces - if ($file=~m:^/~:) { # is a contruction space reference - $location = $file; - $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; - } elsif ($file=~/^\/*uploaded/) { # is an uploaded file - my ($udom,$uname,$filename)= - ($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|); - my $home=&homeserver($uname,$udom); - my $is_me=0; - my @ids=¤t_machine_ids(); - foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } - if ($is_me) { - $location=&Apache::loncommon::propath($udom,$uname). - '/userfiles/'.$filename; - } else { - $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. - $udom.'/'.$uname.'/'.$filename; - } - } else { - $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; - $file=~s:^/res/:/:; - if ( !( $file =~ m:^/:) ) { - $location = $dir. '/'.$file; - } else { - $location = '/home/httpd/html/res'.$file; + my ($dir,$file) = @_; + my $location; + $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces + if ($file=~m:^/~:) { # is a contruction space reference + $location = $file; + $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; + } elsif ($file=~/^\/*uploaded/) { # is an uploaded file + my ($udom,$uname,$filename)= + ($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|); + my $home=&homeserver($uname,$udom); + my $is_me=0; + my @ids=¤t_machine_ids(); + foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } + if ($is_me) { + $location=&Apache::loncommon::propath($udom,$uname). + '/userfiles/'.$filename; + } else { + $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. + $udom.'/'.$uname.'/'.$filename; + } + } elsif ($file =~ /^\/adm\/portfolio\//) { + $file =~ s:^/adm/portfolio/::; + $location = $location=&Apache::loncommon::propath($ENV{'user.domain'},$ENV{'user.name'}).'/userfiles/portfolio/'.$file; + } else { + $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; + $file=~s:^/res/:/:; + if ( !( $file =~ m:^/:) ) { + $location = $dir. '/'.$file; + } else { + $location = '/home/httpd/html/res'.$file; + } } - } - $location=~s://+:/:g; # remove duplicate / - while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. - while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./ - return $location; + $location=~s://+:/:g; # remove duplicate / + while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. + while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./ + return $location; } sub hreflocation { @@ -5390,10 +5585,10 @@ sub thaw_unescape { } sub mod_perl_version { + return 1; if (defined($perlvar{'MODPERL2'})) { return 2; } - return 1; } sub correct_line_ends { @@ -5426,6 +5621,7 @@ BEGIN { # ----------------------------------- Read loncapa.conf and loncapa_apache.conf unless ($readit) { { + # FIXME: Use LONCAPA::Configuration::read_conf here and omit next block open(my $config,") { @@ -5486,18 +5682,32 @@ BEGIN { while (my $configline=<$config>) { next if ($configline =~ /^(\#|\s*$)/); chomp($configline); - my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline); - if ($id && $domain && $role && $name && $ip) { + my ($id,$domain,$role,$name)=split(/:/,$configline); + $name=~s/\s//g; + if ($id && $domain && $role && $name) { $hostname{$id}=$name; $hostdom{$id}=$domain; - $hostip{$id}=$ip; - $iphost{$ip}=$id; if ($role eq 'library') { $libserv{$id}=$name; } } } close($config); } +sub get_iphost { + if (%iphost) { return %iphost; } + foreach my $id (keys(%hostname)) { + my $name=$hostname{$id}; + my $ip = gethostbyname($name); + if (!$ip || length($ip) ne 4) { + &logthis("Skipping host $id name $name no IP found\n"); + next; + } + $ip=inet_ntoa($ip); + push(@{$iphost{$ip}},$id); + } + return %iphost; +} + # ------------------------------------------------------ Read spare server file { open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); @@ -6061,9 +6271,10 @@ returns the data handle =item * symbverify($symb,$thisfn) : verifies that $symb actually exists and is -a possible symb for the URL in $thisfn, returns a 1 on success, 0 on -failure, user must be in a course, as it assumes the existance of the -course initi hash, and uses $ENV('request.course.id'} +a possible symb for the URL in $thisfn, and if is an encryypted +resource that the user accessed using /enc/ returns a 1 on success, 0 +on failure, user must be in a course, as it assumes the existance of +the course initial hash, and uses $ENV('request.course.id'} =item *