[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.263 and 1.270

version 1.263, 2002/08/08 13:42:01 version 1.270, 2002/08/17 19:50:17
Line 820  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 1000  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 1337  sub coursedescription { Line 1435  sub coursedescription {
            while (my ($name,$value) = each %returnhash) {             while (my ($name,$value) = each %returnhash) {
                $envhash{'course.'.$normalid.'.'.$name}=$value;                 $envhash{'course.'.$normalid.'.'.$name}=$value;
            }             }
            $returnhash{'url'}='/res/'.declutter($returnhash{'url'});             $returnhash{'url'}=&clutter($returnhash{'url'});
            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.             $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
        $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;         $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
            $envhash{'course.'.$normalid.'.last_cache'}=time;             $envhash{'course.'.$normalid.'.last_cache'}=time;
Line 1602  sub allowed { Line 1700  sub allowed {
             return 'F';              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='';
     my $statecond=0;      my $statecond=0;
Line 2188  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 2210  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 2975  sub receipt { Line 3082  sub receipt {
 # ------------------------------------------------------------ Serves up a file  # ------------------------------------------------------------ Serves up a file
 # returns either the contents of the file or a -1  # returns either the contents of the file or a -1
 sub getfile {  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);    &repcopy($file);
   if (! -e $file ) { return -1; };    if (! -e $file ) { return -1; };
   my $fh=Apache::File->new($file);    my $fh=Apache::File->new($file);
   my $a='';    my $a='';
   while (<$fh>) { $a .=$_; }    while (<$fh>) { $a .=$_; }
   return $a    return $a;
    }
 }  }
   
 sub filelocation {  sub filelocation {
Line 2991  sub filelocation { Line 3109  sub filelocation {
   if ($file=~m:^/~:) { # is a contruction space reference    if ($file=~m:^/~:) { # is a contruction space reference
     $location = $file;      $location = $file;
     $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;      $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
     } elsif ($file=~/^\/*uploaded/) { # is an uploaded file
       $location=$file;
   } else {    } else {
     $file=~s/^$perlvar{'lonDocRoot'}//;      $file=~s/^$perlvar{'lonDocRoot'}//;
     $file=~s:^/*res::;      $file=~s:^/*res::;
Line 3028  sub declutter { Line 3148  sub declutter {
     return $thisfn;      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  # -------------------------------------------------------- Escape Special Chars
   
 sub escape {  sub escape {
Removed from v.1.263  
changed lines
  Added in v.1.270

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