[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.317.2.1 and 1.325

version 1.317.2.1, 2003/02/01 19:47:37 version 1.325, 2003/02/11 16:42:27
Line 47 Line 47
 # 09/01 Guy Albertelli  # 09/01 Guy Albertelli
 # 09/01,10/01,11/01 Gerd Kortemeyer  # 09/01,10/01,11/01 Gerd Kortemeyer
 # YEAR=2001  # YEAR=2001
 # 02/27/01 Scott Harrison  
 # 3/2 Gerd Kortemeyer  # 3/2 Gerd Kortemeyer
 # 3/15,3/19 Scott Harrison  
 # 3/19,3/20 Gerd Kortemeyer  # 3/19,3/20 Gerd Kortemeyer
 # 3/22,3/27,4/2,4/16,4/17 Scott Harrison  
 # 5/26,5/28 Gerd Kortemeyer  # 5/26,5/28 Gerd Kortemeyer
 # 5/30 H. K. Ng  # 5/30 H. K. Ng
 # 6/1 Gerd Kortemeyer  # 6/1 Gerd Kortemeyer
 # July Guy Albertelli  # July Guy Albertelli
 # 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26,  # 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26,
 # 10/2 Gerd Kortemeyer  # 10/2 Gerd Kortemeyer
 # 10/5,10/10,11/13,11/15 Scott Harrison  
 # 11/17,11/20,11/22,11/29 Gerd Kortemeyer  # 11/17,11/20,11/22,11/29 Gerd Kortemeyer
 # 12/5 Matthew Hall  # 12/5 Matthew Hall
 # 12/5 Guy Albertelli  # 12/5 Guy Albertelli
 # 12/6,12/7,12/12 Gerd Kortemeyer  # 12/6,12/7,12/12 Gerd Kortemeyer
 # 12/18 Scott Harrison  
 # 12/21,12/22,12/27,12/28 Gerd Kortemeyer  # 12/21,12/22,12/27,12/28 Gerd Kortemeyer
 # YEAR=2002  # YEAR=2002
 # 1/4,2/4,2/7 Gerd Kortemeyer  # 1/4,2/4,2/7 Gerd Kortemeyer
Line 832  sub ssi { Line 827  sub ssi {
     return $response->content;      return $response->content;
 }  }
   
   sub externalssi {
       my ($url)=@_;
       my $ua=new LWP::UserAgent;
       my $request=new HTTP::Request('GET',$url);
       my $response=$ua->request($request);
       return $response->content;
   }
   
 # ------- Add a token to a remote URI's query string to vouch for access rights  # ------- Add a token to a remote URI's query string to vouch for access rights
   
 sub tokenwrapper {  sub tokenwrapper {
Line 1109  sub expirespread { Line 1112  sub expirespread {
 # ----------------------------------------------------- Devalidate Spreadsheets  # ----------------------------------------------------- Devalidate Spreadsheets
   
 sub devalidate {  sub devalidate {
     my $symb=shift;      my ($symb,$uname,$udom)=@_;
     my $cid=$ENV{'request.course.id'};       my $cid=$ENV{'request.course.id'}; 
     if ($cid) {      if ($cid) {
  my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':';  # delete the stored spreadsheets for
   # - the student level sheet of this user in course's homespace
   # - the assessment level sheet for this resource 
   #   for this user in user's homespace
    my $key=$uname.':'.$udom.':';
         my $status=          my $status=
     &del('nohist_calculatedsheets',      &del('nohist_calculatedsheets',
  [$key.'studentcalc'],   [$key.'studentcalc'],
Line 1123  sub devalidate { Line 1130  sub devalidate {
  [$key.'assesscalc:'.$symb]);   [$key.'assesscalc:'.$symb]);
         unless ($status eq 'ok ok') {          unless ($status eq 'ok ok') {
            &logthis('Could not devalidate spreadsheet '.             &logthis('Could not devalidate spreadsheet '.
                     $ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '.                      $uname.' at '.$udom.' for '.
     $symb.': '.$status);      $symb.': '.$status);
         }          }
     }      }
Line 1455  sub store { Line 1462  sub store {
     $symb=&symbclean($symb);      $symb=&symbclean($symb);
     if (!$symb) { unless ($symb=&symbread()) { return ''; } }      if (!$symb) { unless ($symb=&symbread()) { return ''; } }
   
     &devalidate($symb);      if (!$domain) { $domain=$ENV{'user.domain'}; }
       if (!$stuname) { $stuname=$ENV{'user.name'}; }
   
       &devalidate($symb,$stuname,$domain);
   
     $symb=escape($symb);      $symb=escape($symb);
     if (!$namespace) {       if (!$namespace) { 
Line 1463  sub store { Line 1473  sub store {
           return '';             return ''; 
        }          } 
     }      }
     if (!$domain) { $domain=$ENV{'user.domain'}; }  
     if (!$stuname) { $stuname=$ENV{'user.name'}; }  
     if (!$home) { $home=$ENV{'user.home'}; }      if (!$home) { $home=$ENV{'user.home'}; }
     my $namevalue='';      my $namevalue='';
     foreach (keys %$storehash) {      foreach (keys %$storehash) {
Line 1486  sub cstore { Line 1494  sub cstore {
     $symb=&symbclean($symb);      $symb=&symbclean($symb);
     if (!$symb) { unless ($symb=&symbread()) { return ''; } }      if (!$symb) { unless ($symb=&symbread()) { return ''; } }
   
     &devalidate($symb);      if (!$domain) { $domain=$ENV{'user.domain'}; }
       if (!$stuname) { $stuname=$ENV{'user.name'}; }
   
       &devalidate($symb,$stuname,$domain);
   
     $symb=escape($symb);      $symb=escape($symb);
     if (!$namespace) {       if (!$namespace) { 
Line 1494  sub cstore { Line 1505  sub cstore {
           return '';             return ''; 
        }          } 
     }      }
     if (!$domain) { $domain=$ENV{'user.domain'}; }  
     if (!$stuname) { $stuname=$ENV{'user.name'}; }  
     if (!$home) { $home=$ENV{'user.home'}; }      if (!$home) { $home=$ENV{'user.home'}; }
   
     my $namevalue='';      my $namevalue='';
Line 1744  sub dump { Line 1753  sub dump {
    return %returnhash;     return %returnhash;
 }  }
   
   # --------------------------------------------------------------- currentdump
   sub currentdump {
      my ($namespace,$udomain,$uname)=@_;
      if (!$udomain) { $udomain = $ENV{'user.domain'}; }
      if (!$uname)   { $uname   = $ENV{'user.name'};   }
      my $uhome = &homeserver($uname,$udomain);
      my $rep=reply("currentdump:$udomain:$uname:$namespace",$uhome);
      return if ($rep =~ /^(error:|no_such_host)/);
      #
      my %returnhash=();
      #
      if ($rep eq "unknown_cmd") { 
          # an old lond will not know currentdump
          # Do a dump and make it look like a currentdump
          my @tmp = &dump($namespace,$udomain,$uname,'.');
          return if ($tmp[0] =~ /^(error:|no_such_host)/);
          my %hash = @tmp;
          @tmp=();
          # Code ripped from lond, essentially.  The only difference
          # here is the unescaping done by lonnet::dump().  Conceivably
          # we might run in to problems with parameter names =~ /^v\./
          while (my ($key,$value) = each(%hash)) {
              my ($v,$symb,$param) = split(/:/,$key);
              next if ($v eq 'version' || $symb eq 'keys');
              next if (exists($returnhash{$symb}) &&
                       exists($returnhash{$symb}->{$param}) &&
                       $returnhash{$symb}->{'v.'.$param} > $v);
              $returnhash{$symb}->{$param}=$value;
              $returnhash{$symb}->{'v.'.$param}=$v;
          }
          #
          # Remove all of the keys in the hashes which keep track of
          # the version of the parameter.
          while (my ($symb,$param_hash) = each(%returnhash)) {
              # use a foreach because we are going to delete from the hash.
              foreach my $key (keys(%$param_hash)) {
                  delete($param_hash->{$key}) if ($key =~ /^v\./);
              }
          }
      } else {
          my @pairs=split(/\&/,$rep);
          foreach (@pairs) {
              my ($key,$value)=split(/=/,$_);
              my ($symb,$param) = split(/:/,$key);
              $returnhash{&unescape($symb)}->{&unescape($param)} = 
                                                             &unescape($value);
          }
      }
      return %returnhash;
   }
   
 # --------------------------------------------------------------- put interface  # --------------------------------------------------------------- put interface
   
 sub put {  sub put {
Line 3034  sub metadata { Line 3094  sub metadata {
                       my $unikey='parameter'.$keyroot.'_'.$name;                        my $unikey='parameter'.$keyroot.'_'.$name;
                       $metathesekeys{$unikey}=1;                        $metathesekeys{$unikey}=1;
                       $metacache{$uri.':'.$unikey.'.part'}=$part;                        $metacache{$uri.':'.$unikey.'.part'}=$part;
                       unless                         unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
                        (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {    $metacache{$uri.':'.$unikey.'.'.$subp}=$value;
                          $metacache{$uri.':'.$unikey.'.'.$subp}=$value;        }
         if (defined($metacache{$uri.':'.$unikey.'.default'})) {
     $metacache{$uri.':'.$unikey}=
        $metacache{$uri.':'.$unikey.'.default'}
       }        }
                   }                    }
               }                }
Line 3086  sub metadata { Line 3149  sub metadata {
               foreach (@{$token->[3]}) {                foreach (@{$token->[3]}) {
   $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};    $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
               }                }
               unless (        my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
                  $metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry))        my $default=$metacache{$uri.':'.$unikey.'.default'};
       ) { $metacache{$uri.':'.$unikey}=        if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
       $metacache{$uri.':'.$unikey.'.default'};    # only ws inside the tag, and not in default, so use default
       }                    # as value
     $metacache{$uri.':'.$unikey}=$default;
         } else {
     # either something interesting inside the tag or default
                     # uninteresting
     $metacache{$uri.':'.$unikey}=$internaltext;
         }
 # end of not-a-package not-a-library import  # end of not-a-package not-a-library import
    }     }
 # end of not-a-package start tag  # end of not-a-package start tag
Removed from v.1.317.2.1  
changed lines
  Added in v.1.325

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