[BACK]Return to lonnet.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.260 and 1.268

version 1.260, 2002/08/02 21:11:55 version 1.268, 2002/08/17 18:23:27
Line 608  sub userenvironment { Line 608  sub userenvironment {
     return %returnhash;      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  # ----------------------------- Subscribe to a resource, return URL if possible
   
 sub subscribe {  sub subscribe {
Line 766  sub userfileupload { Line 778  sub userfileupload {
     }      }
 # Notify homeserver to grep it  # 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 the URL to it
     return '/uploaded/'.$path.$fname;              return '/uploaded/'.$path.$fname;
       } else {
           return '/adm/notfound.html';
       }    
 }  }
   
 # ------------------------------------------------------------------------- Log  # ------------------------------------------------------------------------- Log
Line 803  sub flushcourselogs { Line 820  sub flushcourselogs {
         my $entry=$_;          my $entry=$_;
         $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;          $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;
         my %temphash=($entry => $accesshash{$entry});          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};      delete $accesshash{$entry};
         }          }
     }      }
Line 983  sub devalidate { Line 1000  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 {  sub arrayref2str {
   my ($arrayref) = @_;    my ($arrayref) = @_;
   my $result='_ARRAY_REF__';    my $result='__ARRAY_REF__';
   foreach my $elem (@$arrayref) {    foreach my $elem (@$arrayref) {
     if (ref($elem) eq 'ARRAY') {      if(ref($elem) eq 'ARRAY') {
       $result.=&escape(&arrayref2str($elem)).'&';        $result.=&arrayref2str($elem).'&';
     } elsif (ref($elem) eq 'HASH') {      } elsif(ref($elem) eq 'HASH') {
       $result.=&escape(&hashref2str($elem)).'&';        $result.=&hashref2str($elem).'&';
     } elsif (ref($elem)) {      } elsif(ref($elem)) {
       &logthis("Got a ref of ".(ref($elem))." skipping.");        #print("Got a ref of ".(ref($elem))." skipping.");
     } else {      } else {
       $result.=&escape($elem).'&';        $result.=&escape($elem).'&';
     }      }
   }    }
   $result=~s/\&$//;    $result=~s/\&$//;
     $result .= '__END_ARRAY_REF__';
   return $result;    return $result;
 }  }
   
 sub hash2str {  sub hash2str {
   my (%hash) = @_;    my (%hash) = @_;
   my $result=&hashref2str(\%hash);    my $result=&hashref2str(\%hash);
   $result=~s/^_HASH_REF__//;    $result=~s/^__HASH_REF__//;
     $result=~s/__END_HASH_REF__$//;
   return $result;    return $result;
 }  }
   
 sub hashref2str {  sub hashref2str {
   my ($hashref)=@_;    my ($hashref)=@_;
   my $result='_HASH_REF__';    my $result='__HASH_REF__';
   foreach (keys(%$hashref)) {    foreach (keys(%$hashref)) {
     if (ref($_) eq 'ARRAY') {      if (ref($_) eq 'ARRAY') {
       $result.=&escape(&arrayref2str($_)).'=';        $result.=&arrayref2str($_).'=';
     } elsif (ref($_) eq 'HASH') {      } elsif (ref($_) eq 'HASH') {
       $result.=&escape(&hashref2str($_)).'=';        $result.=&hashref2str($_).'=';
     } elsif (ref($_)) {      } elsif (ref($_)) {
       &logthis("Got a ref of ".(ref($_))." skipping.");        $result.='=';
         #print("Got a ref of ".(ref($_))." skipping.");
     } else {      } else {
       $result.=&escape($_).'=';   if ($_) {$result.=&escape($_).'=';} else { last; }
     }      }
   
     if (ref($$hashref{$_}) eq 'ARRAY') {      if(ref($hashref->{$_}) eq 'ARRAY') {
       $result.=&escape(&arrayref2str($$hashref{$_})).'&';        $result.=&arrayref2str($hashref->{$_}).'&';
     } elsif (ref($$hashref{$_}) eq 'HASH') {      } elsif(ref($hashref->{$_}) eq 'HASH') {
       $result.=&escape(&hashref2str($$hashref{$_})).'&';        $result.=&hashref2str($hashref->{$_}).'&';
     } elsif (ref($$hashref{$_})) {      } elsif(ref($hashref->{$_})) {
       &logthis("Got a ref of ".(ref($$hashref{$_}))." skipping.");         $result.='&';
         #print("Got a ref of ".(ref($hashref->{$_}))." skipping.");
     } else {      } else {
       $result.=&escape($$hashref{$_}).'&';        $result.=&escape($hashref->{$_}).'&';
     }      }
   }    }
   $result=~s/\&$//;    $result=~s/\&$//;
     $result .= '__END_HASH_REF__';
   return $result;    return $result;
 }  }
   
 sub str2hash {  sub str2hash {
       my ($string)=@_;
       my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__');
       return %$hash;
   }
   
   sub str2hashref {
   my ($string) = @_;    my ($string) = @_;
   my %returnhash;  
   foreach (split(/\&/,$string)) {    my %hash;
     my ($name,$value)=split(/\=/,$_);  
     $name=&unescape($name);    if($string !~ /^__HASH_REF__/) {
     $value=&unescape($value);        if (! ($string eq '' || !defined($string))) {
     if ($value =~ /^_HASH_REF__/) {    $hash{'error'}='Not hash reference';
       $value =~ s/^_HASH_REF__//;        }
       my %hash=&str2hash($value);        return (\%hash, $string);
       $value=\%hash;    }
     } elsif ($value =~ /^_ARRAY_REF__/) {  
       $value =~ s/^_ARRAY_REF__//;    $string =~ s/^__HASH_REF__//;
       my @array=&str2array($value);  
       $value=\@array;    while($string !~ /^__END_HASH_REF__/) {
     }        #key
     $returnhash{$name}=$value;        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;
   }    }
   return (%returnhash);  
     $string =~ s/^__END_HASH_REF__//;
   
     return (\%hash, $string);
 }  }
   
 sub str2array {  sub str2array {
       my ($string)=@_;
       my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__');
       return @$array;
   }
   
   sub str2arrayref {
   my ($string) = @_;    my ($string) = @_;
   my @returnarray;    my @array;
   foreach my $value (split(/\&/,$string)) {  
     $value=&unescape($value);    if($string !~ /^__ARRAY_REF__/) {
     if ($value =~ /^_HASH_REF__/) {        if (! ($string eq '' || !defined($string))) {
       $value =~ s/^_HASH_REF__//;    $array[0]='Array reference error';
       my %hash=&str2hash($value);        }
       $value=\%hash;        return (\@array, $string);
     } elsif ($value =~ /^_ARRAY_REF__/) {    }
       $value =~ s/^_ARRAY_REF__//;  
       my @array=&str2array($value);    $string =~ s/^__ARRAY_REF__//;
       $value=\@array;  
     }    while($string !~ /^__END_ARRAY_REF__/) {
     push(@returnarray,$value);        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  # -------------------------------------------------------------------Temp Store
Line 1580  sub allowed { Line 1695  sub allowed {
  return '';   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='';      my $thisallowed='';
Line 2167  sub writecoursepref { Line 2293  sub writecoursepref {
 # ---------------------------------------------------------- Make/modify course  # ---------------------------------------------------------- Make/modify course
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url)=@_;      my ($udom,$description,$url,$course_server)=@_;
     $url=&declutter($url);      $url=&declutter($url);
     my $cid='';      my $cid='';
     unless (&allowed('ccc',$ENV{'user.domain'})) {      unless (&allowed('ccc',$udom)) {
         return 'refused';  
     }  
     unless ($udom eq $ENV{'user.domain'}) {  
         return 'refused';          return 'refused';
     }      }
 # ------------------------------------------------------------------- Create ID  # ------------------------------------------------------------------- Create ID
Line 2189  sub createcourse { Line 2312  sub createcourse {
            return 'error: unable to generate unique course-ID';             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  # ------------------------------------------------------------- Make the course
     my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',      my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
                       $ENV{'user.home'});                        $course_server);
     unless ($reply eq 'ok') { return 'error: '.$reply; }      unless ($reply eq 'ok') { return 'error: '.$reply; }
     $uhome=&homeserver($uname,$udom,'true');      $uhome=&homeserver($uname,$udom,'true');
     if (($uhome eq '') || ($uhome eq 'no_host')) {       if (($uhome eq '') || ($uhome eq 'no_host')) { 
Line 2703  sub metadata { Line 2831  sub metadata {
 # the next is the end of "start tag"  # the next is the end of "start tag"
  }   }
        }         }
    &metadata_generate_part0(\%metathesekeys,\%metacache,$uri);
        $metacache{$uri.':keys'}=join(',',keys %metathesekeys);         $metacache{$uri.':keys'}=join(',',keys %metathesekeys);
        $metacache{$uri.':cachedtimestamp'}=time;         $metacache{$uri.':cachedtimestamp'}=time;
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
Line 2710  sub metadata { Line 2839  sub metadata {
     return $metacache{$uri.':'.$what};      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  # ------------------------------------------------- Update symbolic store links
   
 sub symblist {  sub symblist {
Line 2978  sub declutter { Line 3135  sub declutter {
     return $thisfn;      return $thisfn;
 }  }
   
   # ------------------------------------------------------------- Clutter up URLs
   
   sub clutter {
       my $thisfn='/'.&declutter(shift);
       unless ($thisfn=~/^\/(uploaded|adm)\//) { $thisfn='/res'.$thisfn; }
       return $thisfn;
   }
   
 # -------------------------------------------------------- Escape Special Chars  # -------------------------------------------------------- Escape Special Chars
   
 sub escape {  sub escape {
Removed from v.1.260  
changed lines
  Added in v.1.268

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>