--- loncom/lonnet/perl/lonnet.pm 2004/12/04 18:35:27 1.573 +++ loncom/lonnet/perl/lonnet.pm 2005/01/19 01:25:35 1.590 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.573 2004/12/04 18:35:27 banghart Exp $ +# $Id: lonnet.pm,v 1.590 2005/01/19 01:25:35 banghart Exp $ # # Copyright Michigan State University Board of Trustees # @@ -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'; } @@ -2363,7 +2365,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 +2397,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 '')) { @@ -2776,7 +2785,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 +3066,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 +3368,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{$_}).'&'; } @@ -3818,41 +3834,44 @@ sub save_selected_files { my ($user, $path, @files) = @_; my $filename = $user."savedfiles"; my @other_files = &files_not_in_path($user, $path); - foreach (@other_files) { - &logthis("other dir file $_"); - } - foreach (@files) { - &logthis("current dir file $_"); - } - open OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename; + open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); foreach my $file (@files) { - print OUT $ENV{'form.currentpath'}.$file."\n"; + print (OUT $ENV{'form.currentpath'}.$file."\n"); } foreach my $file (@other_files) { - print OUT $file."\n"; + print (OUT $file."\n"); } - close OUT; + 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; + 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; + 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; + close (IN); + return (\%return_files); } # called in portfolio select mode, to show files selected NOT in current directory @@ -3861,21 +3880,21 @@ sub files_not_in_path { my $filename = $user."savedfiles"; my @return_files; my $path_part; - open IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename; + 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; + 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); + push (@return_files, ($path_and_file)); } } - close OUT; - return @return_files; + close (OUT); + return (@return_files); } #--------------------------------------------------------------Get Marked as Read Only @@ -3897,7 +3916,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 { @@ -4409,6 +4446,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"}; } @@ -4690,7 +4728,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; @@ -4766,8 +4806,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); @@ -4962,8 +5005,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 { @@ -5002,7 +5062,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') { @@ -5099,6 +5165,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)=@_; { @@ -5118,6 +5208,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 =~/([,:])/) { @@ -5324,39 +5433,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 { @@ -5456,10 +5568,10 @@ sub thaw_unescape { } sub mod_perl_version { + return 1; if (defined($perlvar{'MODPERL2'})) { return 2; } - return 1; } sub correct_line_ends { @@ -5492,6 +5604,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,") { @@ -6127,9 +6240,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 *