--- loncom/lonnet/perl/lonnet.pm 2002/08/02 21:11:55 1.260 +++ loncom/lonnet/perl/lonnet.pm 2002/08/30 18:36:03 1.276 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.260 2002/08/02 21:11:55 ng Exp $ +# $Id: lonnet.pm,v 1.276 2002/08/30 18:36:03 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -608,6 +608,18 @@ sub userenvironment { return %returnhash; } +# -------------------------------------------------------------------- New chat + +sub chatsend { + my ($newentry,$anon)=@_; + my $cnum=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; + my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; + my $chome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + &reply('chatsend:'.$cdom.':'.$cnum.':'. + &escape($ENV{'user.domain'}.':'.$ENV{'user.name'}.':'.$anon.':'. + &escape($newentry)),$chome); +} + # ----------------------------- Subscribe to a resource, return URL if possible sub subscribe { @@ -749,6 +761,12 @@ sub userfileupload { $docudom=$ENV{'user.domain'}; $docuhome=$ENV{'user.home'}; } + return + &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); +} + +sub finishuserfileupload { + my ($docuname,$docudom,$docuhome,$formname,$fname)=@_; my $path=$docudom.'/'.$docuname.'/'; my $filepath=$perlvar{'lonDocRoot'}; my @parts=split(/\//,$filepath.'/userfiles/'.$path); @@ -766,10 +784,15 @@ sub userfileupload { } # Notify homeserver to grep it # -# FIXME - this still needs to happen + if +(&reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome) eq 'ok') + { # # Return the URL to it - return '/uploaded/'.$path.$fname; + return '/uploaded/'.$path.$fname; + } else { + return '/adm/notfound.html'; + } } # ------------------------------------------------------------------------- Log @@ -803,7 +826,7 @@ sub flushcourselogs { my $entry=$_; $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/; my %temphash=($entry => $accesshash{$entry}); - if (&Apache::lonnet::put('resevaldata',\%temphash,$1,$2) eq 'ok') { + if (&Apache::lonnet::put('nohist_resevaldata',\%temphash,$1,$2) eq 'ok') { delete $accesshash{$entry}; } } @@ -983,97 +1006,195 @@ sub devalidate { } } +sub get_scalar { + my ($string,$end) = @_; + my $value; + if ($$string =~ s/^([^&]*?)($end)/$2/) { + $value = $1; + } elsif ($$string =~ s/^([^&]*?)&//) { + $value = $1; + } + return &unescape($value); +} + +sub array2str { + my (@array) = @_; + my $result=&arrayref2str(\@array); + $result=~s/^__ARRAY_REF__//; + $result=~s/__END_ARRAY_REF__$//; + return $result; +} + sub arrayref2str { my ($arrayref) = @_; - my $result='_ARRAY_REF__'; + my $result='__ARRAY_REF__'; foreach my $elem (@$arrayref) { - if (ref($elem) eq 'ARRAY') { - $result.=&escape(&arrayref2str($elem)).'&'; - } elsif (ref($elem) eq 'HASH') { - $result.=&escape(&hashref2str($elem)).'&'; - } elsif (ref($elem)) { - &logthis("Got a ref of ".(ref($elem))." skipping."); + if(ref($elem) eq 'ARRAY') { + $result.=&arrayref2str($elem).'&'; + } elsif(ref($elem) eq 'HASH') { + $result.=&hashref2str($elem).'&'; + } elsif(ref($elem)) { + #print("Got a ref of ".(ref($elem))." skipping."); } else { $result.=&escape($elem).'&'; } } $result=~s/\&$//; + $result .= '__END_ARRAY_REF__'; return $result; } sub hash2str { my (%hash) = @_; my $result=&hashref2str(\%hash); - $result=~s/^_HASH_REF__//; + $result=~s/^__HASH_REF__//; + $result=~s/__END_HASH_REF__$//; return $result; } sub hashref2str { my ($hashref)=@_; - my $result='_HASH_REF__'; + my $result='__HASH_REF__'; foreach (keys(%$hashref)) { if (ref($_) eq 'ARRAY') { - $result.=&escape(&arrayref2str($_)).'='; + $result.=&arrayref2str($_).'='; } elsif (ref($_) eq 'HASH') { - $result.=&escape(&hashref2str($_)).'='; + $result.=&hashref2str($_).'='; } elsif (ref($_)) { - &logthis("Got a ref of ".(ref($_))." skipping."); + $result.='='; + #print("Got a ref of ".(ref($_))." skipping."); } else { - $result.=&escape($_).'='; + if ($_) {$result.=&escape($_).'=';} else { last; } } - if (ref($$hashref{$_}) eq 'ARRAY') { - $result.=&escape(&arrayref2str($$hashref{$_})).'&'; - } elsif (ref($$hashref{$_}) eq 'HASH') { - $result.=&escape(&hashref2str($$hashref{$_})).'&'; - } elsif (ref($$hashref{$_})) { - &logthis("Got a ref of ".(ref($$hashref{$_}))." skipping."); + if(ref($hashref->{$_}) eq 'ARRAY') { + $result.=&arrayref2str($hashref->{$_}).'&'; + } elsif(ref($hashref->{$_}) eq 'HASH') { + $result.=&hashref2str($hashref->{$_}).'&'; + } elsif(ref($hashref->{$_})) { + $result.='&'; + #print("Got a ref of ".(ref($hashref->{$_}))." skipping."); } else { - $result.=&escape($$hashref{$_}).'&'; + $result.=&escape($hashref->{$_}).'&'; } } $result=~s/\&$//; + $result .= '__END_HASH_REF__'; return $result; } sub str2hash { + my ($string)=@_; + my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__'); + return %$hash; +} + +sub str2hashref { my ($string) = @_; - my %returnhash; - foreach (split(/\&/,$string)) { - my ($name,$value)=split(/\=/,$_); - $name=&unescape($name); - $value=&unescape($value); - if ($value =~ /^_HASH_REF__/) { - $value =~ s/^_HASH_REF__//; - my %hash=&str2hash($value); - $value=\%hash; - } elsif ($value =~ /^_ARRAY_REF__/) { - $value =~ s/^_ARRAY_REF__//; - my @array=&str2array($value); - $value=\@array; - } - $returnhash{$name}=$value; + + my %hash; + + if($string !~ /^__HASH_REF__/) { + if (! ($string eq '' || !defined($string))) { + $hash{'error'}='Not hash reference'; + } + return (\%hash, $string); } - return (%returnhash); + + $string =~ s/^__HASH_REF__//; + + while($string !~ /^__END_HASH_REF__/) { + #key + my $key=''; + if($string =~ /^__HASH_REF__/) { + ($key, $string)=&str2hashref($string); + if(defined($key->{'error'})) { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($key, $string)=&str2arrayref($string); + if($key->[0] eq 'Array reference error') { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } else { + $string =~ s/^(.*?)=//; + $key=&unescape($1); + } + $string =~ s/^=//; + + #value + my $value=''; + if($string =~ /^__HASH_REF__/) { + ($value, $string)=&str2hashref($string); + if(defined($value->{'error'})) { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($value, $string)=&str2arrayref($string); + if($value->[0] eq 'Array reference error') { + $hash{'error'}='Bad data'; + return (\%hash, $string); + } + } else { + $value=&get_scalar(\$string,'__END_HASH_REF__'); + } + $string =~ s/^&//; + + $hash{$key}=$value; + } + + $string =~ s/^__END_HASH_REF__//; + + return (\%hash, $string); } sub str2array { + my ($string)=@_; + my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__'); + return @$array; +} + +sub str2arrayref { my ($string) = @_; - my @returnarray; - foreach my $value (split(/\&/,$string)) { - $value=&unescape($value); - if ($value =~ /^_HASH_REF__/) { - $value =~ s/^_HASH_REF__//; - my %hash=&str2hash($value); - $value=\%hash; - } elsif ($value =~ /^_ARRAY_REF__/) { - $value =~ s/^_ARRAY_REF__//; - my @array=&str2array($value); - $value=\@array; - } - push(@returnarray,$value); + my @array; + + if($string !~ /^__ARRAY_REF__/) { + if (! ($string eq '' || !defined($string))) { + $array[0]='Array reference error'; + } + return (\@array, $string); + } + + $string =~ s/^__ARRAY_REF__//; + + while($string !~ /^__END_ARRAY_REF__/) { + my $value=''; + if($string =~ /^__HASH_REF__/) { + ($value, $string)=&str2hashref($string); + if(defined($value->{'error'})) { + $array[0] ='Array reference error'; + return (\@array, $string); + } + } elsif($string =~ /^__ARRAY_REF__/) { + ($value, $string)=&str2arrayref($string); + if($value->[0] eq 'Array reference error') { + $array[0] ='Array reference error'; + return (\@array, $string); + } + } else { + $value=&get_scalar(\$string,'__END_ARRAY_REF__'); + } + $string =~ s/^&//; + + push(@array, $value); } - return (@returnarray); + + $string =~ s/^__END_ARRAY_REF__//; + + return (\@array, $string); } # -------------------------------------------------------------------Temp Store @@ -1320,7 +1441,7 @@ sub coursedescription { while (my ($name,$value) = each %returnhash) { $envhash{'course.'.$normalid.'.'.$name}=$value; } - $returnhash{'url'}='/res/'.declutter($returnhash{'url'}); + $returnhash{'url'}=&clutter($returnhash{'url'}); $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; $envhash{'course.'.$normalid.'.last_cache'}=time; @@ -1448,6 +1569,9 @@ sub get { my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome); my @pairs=split(/\&/,$rep); + if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { + return @pairs; + } my %returnhash=(); my $i=0; foreach (@$storearr) { @@ -1580,6 +1704,17 @@ sub allowed { return ''; } } + if ($ENV{'request.role'}=~ /li\.\//) { + # Library role, so allow browsing of resources in this domain. + return 'F'; + } + } + # Domain coordinator is trying to create a course + if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) { + # uri is the requested domain in this case. + # comparison to 'request.role.domain' shows if the user has selected + # a role of dc for the domain in question. + return 'F' if ($uri eq $ENV{'request.role.domain'}); } my $thisallowed=''; @@ -2011,7 +2146,8 @@ sub modifyuserauth { my $uhome=&homeserver($uname,$udom); unless (&allowed('mau',$udom)) { return 'refused'; } &logthis('Call to modify user authentication '.$udom.', '.$uname.', '. - $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); + $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}. + ' in domain '.$ENV{'request.role.domain'}); my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. &escape($upass),$uhome); &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, @@ -2042,7 +2178,8 @@ sub modifyuser { $last.', '.$gene.'(forceid: '.$forceid.')'. (defined($desiredhome) ? ' desiredhome = '.$desiredhome : ' desiredhome not specified'). - ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); + ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}. + ' in domain '.$ENV{'request.role.domain'}); my $uhome=&homeserver($uname,$udom,'true'); # ----------------------------------------------------------------- Create User if (($uhome eq 'no_host') && ($umode) && ($upass)) { @@ -2167,13 +2304,10 @@ sub writecoursepref { # ---------------------------------------------------------- Make/modify course sub createcourse { - my ($udom,$description,$url)=@_; + my ($udom,$description,$url,$course_server,$nonstandard)=@_; $url=&declutter($url); my $cid=''; - unless (&allowed('ccc',$ENV{'user.domain'})) { - return 'refused'; - } - unless ($udom eq $ENV{'user.domain'}) { + unless (&allowed('ccc',$udom)) { return 'refused'; } # ------------------------------------------------------------------- Create ID @@ -2189,17 +2323,41 @@ sub createcourse { return 'error: unable to generate unique course-ID'; } } +# ------------------------------------------------ Check supplied server name + $course_server = $ENV{'user.homeserver'} if (! defined($course_server)); + if (! exists($libserv{$course_server})) { + return 'error:bad server name '.$course_server; + } # ------------------------------------------------------------- Make the course my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', - $ENV{'user.home'}); + $course_server); unless ($reply eq 'ok') { return 'error: '.$reply; } $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: no such course'; } +# ----------------------------------------------------------------- Course made + my $topurl=$url; + unless ($nonstandard) { +# ------------------------------------------ For standard courses, make top url + my $mapurl=&clutter($url); + $ENV{'form.initmap'}=(< + + + + + + +ENDINITMAP + $topurl=&declutter( + &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence') + ); + } +# ----------------------------------------------------------- Write preferences &writecoursepref($udom.'_'.$uname, ('description' => $description, - 'url' => $url)); + 'url' => $topurl)); return '/'.$udom.'/'.$uname; } @@ -2300,6 +2458,30 @@ sub dirlist { } } +# --------------------------------------------- GetFileTimestamp +# This function utilizes dirlist and returns the date stamp for +# when it was last modified. It will also return an error of -1 +# if an error occurs + +sub GetFileTimestamp { + my ($studentDomain,$studentName,$filename,$root)=@_; + $studentDomain=~s/\W//g; + $studentName=~s/\W//g; + my $subdir=$studentName.'__'; + $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; + my $proname="$studentDomain/$subdir/$studentName"; + $proname .= '/'.$filename; + my @dir = &Apache::lonnet::dirlist($proname, $studentDomain, $studentName, + $root); + my $fileStat = $dir[0]; + my @stats = split('&', $fileStat); + if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { + return $stats[9]; + } else { + return -1; + } +} + # -------------------------------------------------------- Value of a Condition sub directcondval { @@ -2615,7 +2797,7 @@ sub metadata { my $package=$token->[2]->{'package'}; my $keyroot=''; if ($prefix) { - $keyroot.='_'.$prefix; + $keyroot.=$prefix; } else { if (defined($token->[2]->{'part'})) { $keyroot.='_'.$token->[2]->{'part'}; @@ -2673,12 +2855,14 @@ sub metadata { # # Importing a library here # - if (defined($depthcount)) { $depthcount++; } else - { $depthcount=0; } if ($depthcount<20) { - foreach (split(/\,/,&metadata($uri,'keys', - $parser->get_text('/import'),$unikey, - $depthcount))) { + my $location=$parser->get_text('/import'); + my $dir=$filename; + $dir=~s|[^/]*$||; + $location=&filelocation($dir,$location); + foreach (sort(split(/\,/,&metadata($uri,'keys', + $location,$unikey, + $depthcount+1)))) { $metathesekeys{$_}=1; } } @@ -2704,12 +2888,42 @@ sub metadata { } } $metacache{$uri.':keys'}=join(',',keys %metathesekeys); + &metadata_generate_part0(\%metathesekeys,\%metacache,$uri); + $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys); $metacache{$uri.':cachedtimestamp'}=time; # this is the end of "was not already recently cached } return $metacache{$uri.':'.$what}; } +sub metadata_generate_part0 { + my ($metadata,$metacache,$uri) = @_; + my %allnames; + foreach my $metakey (sort keys %$metadata) { + if ($metakey=~/^parameter\_(.*)/) { + my $part=$$metacache{$uri.':'.$metakey.'.part'}; + my $name=$$metacache{$uri.':'.$metakey.'.name'}; + if (! exists($$metadata{'parameter_0_'.$name})) { + $allnames{$name}=$part; + } + } + } + foreach my $name (keys(%allnames)) { + $$metadata{"parameter_0_$name"}=1; + my $key="$uri:parameter_0_$name"; + $$metacache{"$key.part"}='0'; + $$metacache{"$key.name"}=$name; + $$metacache{"$key.type"}=$$metacache{$uri.':parameter_'. + $allnames{$name}.'_'.$name. + '.type'}; + my $olddis=$$metacache{$uri.':parameter_'.$allnames{$name}.'_'.$name. + '.display'}; + my $expr='\\[Part: '.$allnames{$name}.'\\]'; + $olddis=~s/$expr/\[Part: 0\]/; + $$metacache{"$key.display"}=$olddis; + } +} + # ------------------------------------------------- Update symbolic store links sub symblist { @@ -2925,13 +3139,24 @@ sub receipt { # ------------------------------------------------------------ Serves up a file # returns either the contents of the file or a -1 sub getfile { - my $file=shift; + my $file=shift; + if ($file=~/^\/*uploaded\//) { # user file + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',&tokenwrapper($file)); + my $response=$ua->request($request); + if ($response->is_success()) { + return $response->content; + } else { + return -1; + } + } else { # normal file from res space &repcopy($file); if (! -e $file ) { return -1; }; my $fh=Apache::File->new($file); my $a=''; while (<$fh>) { $a .=$_; } - return $a + return $a; + } } sub filelocation { @@ -2941,6 +3166,8 @@ sub filelocation { if ($file=~m:^/~:) { # is a contruction space reference $location = $file; $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; + } elsif ($file=~/^\/*uploaded/) { # is an uploaded file + $location=$file; } else { $file=~s/^$perlvar{'lonDocRoot'}//; $file=~s:^/*res::; @@ -2978,6 +3205,16 @@ sub declutter { return $thisfn; } +# ------------------------------------------------------------- Clutter up URLs + +sub clutter { + my $thisfn='/'.&declutter(shift); + unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) { + $thisfn='/res'.$thisfn; + } + return $thisfn; +} + # -------------------------------------------------------- Escape Special Chars sub escape {