[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.638 and 1.650.2.1

version 1.638, 2005/06/13 20:23:54 version 1.650.2.1, 2005/08/17 19:18:36
Line 1302  sub userfileupload { Line 1302  sub userfileupload {
     if ($coursedoc) {      if ($coursedoc) {
  my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};   my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
  my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};   my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
         if ($env{'form.folder'} =~ m/^default/) {          if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
             return &finishuserfileupload($docuname,$docudom,              return &finishuserfileupload($docuname,$docudom,
  $formname,$fname,$parser,$allfiles,   $formname,$fname,$parser,$allfiles,
  $codebase);   $codebase);
Line 1368  sub finishuserfileupload { Line 1368  sub finishuserfileupload {
 }  }
   
 sub extract_embedded_items {  sub extract_embedded_items {
     my ($filepath,$file,$allfiles,$codebase) = @_;      my ($filepath,$file,$allfiles,$codebase,$content) = @_;
     my @state = ();      my @state = ();
     my %javafiles = (      my %javafiles = (
                       codebase => '',                        codebase => '',
Line 1379  sub extract_embedded_items { Line 1379  sub extract_embedded_items {
                       src => '',                        src => '',
                       movie => '',                        movie => '',
                      );                       );
     my $p = HTML::Parser->new      my $p;
     (      if ($content) {
         xml_mode => 1,          $p = HTML::LCParser->new($content);
         start_h =>      } else {
             [sub {          $p = HTML::LCParser->new($filepath.'/'.$file);
                  my ($tagname, $attr) = @_;      }
                  push (@state, $tagname);      while (my $t=$p->get_token()) {
                  if (lc($tagname) eq 'img') {   if ($t->[0] eq 'S') {
                      if (exists($$allfiles{$attr->{'src'}})) {      my ($tagname, $attr) = ($t->[1],$t->[2]);
                          unless (grep/^src$/,@{$$allfiles{$attr->{'src'}}}) {      push (@state, $tagname);
                              push (@{$$allfiles{$attr->{'src'}}},&escape('src'));              if (lc($tagname) eq 'allow') {
                          }                  &add_filetype($allfiles,$attr->{'src'},'src');
                      } else {              }
                          @{$$allfiles{$attr->{'src'}}} = (&escape('src'));      if (lc($tagname) eq 'img') {
                      }   &add_filetype($allfiles,$attr->{'src'},'src');
                  }      }
                  if (lc($tagname) eq 'object') {              if (lc($tagname) eq 'script') {
                      foreach my $item (keys (%javafiles)) {                  if ($attr->{'archive'} =~ /\.jar$/i) {
                          $javafiles{$item} = '';                      &add_filetype($allfiles,$attr->{'archive'},'archive');
                      }                  } else {
                  }                      &add_filetype($allfiles,$attr->{'src'},'src');
                  if (lc($state[-2]) eq 'object') {                  }
                      if (lc($tagname) eq 'param') {              }
                          my $name = lc($attr->{'name'});              if (lc($tagname) eq 'link') {
                          foreach my $item (keys (%mediafiles)) {                  if (lc($attr->{'rel'}) eq 'stylesheet') { 
                              if ($name eq $item) {                      &add_filetype($allfiles,$attr->{'href'},'href');
                                  if (exists($$allfiles{$attr->{'value'}})) {                  }
                                      unless(grep/^value$/,@{$$allfiles{$attr->{'value'}}}) {              }
                                          push(@{$$allfiles{$attr->{'value'}}},&escape('value'));      if (lc($tagname) eq 'object' ||
                                      }   (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')) {
                                  } else {   foreach my $item (keys(%javafiles)) {
                                      @{$$allfiles{$attr->{'value'}}} = (&escape('value'));      $javafiles{$item} = '';
                                  }   }
                                  last;      }
                              }      if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {
                          }   my $name = lc($attr->{'name'});
                          foreach my $item (keys (%javafiles)) {   foreach my $item (keys(%javafiles)) {
                              if ($name eq $item) {      if ($name eq $item) {
                                  $javafiles{$item} = $attr->{'value'};   $javafiles{$item} = $attr->{'value'};
                                  last;   last;
                              }      }
                          }   }
                      }   foreach my $item (keys(%mediafiles)) {
                  }      if ($name eq $item) {
                  if (lc($tagname) eq 'embed') {   &add_filetype($allfiles, $attr->{'value'}, 'value');
                      unless (lc($state[-2]) eq 'object') {   last;
                          foreach my $item (keys (%javafiles)) {      }
                              $javafiles{$item} = '';   }
                          }      }
                      }      if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {
                      foreach my $item (keys (%javafiles)) {   foreach my $item (keys(%javafiles)) {
                          if ($attr->{$item}) {      if ($attr->{$item}) {
                              $javafiles{$item} = $attr->{$item};   $javafiles{$item} = $attr->{$item};
                              last;   last;
                          }      }
                      }   }
                      foreach my $item (keys (%mediafiles)) {   foreach my $item (keys(%mediafiles)) {
                          if ($attr->{$item}) {      if ($attr->{$item}) {
                              if (exists($$allfiles{$attr->{$item}})) {   &add_filetype($allfiles,$attr->{$item},$item);
                                  unless (grep/^$item$/,@{$$allfiles{$item}}) {   last;
                                      push(@{$$allfiles{$attr->{$item}}},&escape($item));      }
                                  }   }
                              } else {      }
                                  @{$$allfiles{$attr->{$item}}} = (&escape($item));   } elsif ($t->[0] eq 'E') {
                              }      my ($tagname) = ($t->[1]);
                              last;      if ($javafiles{'codebase'} ne '') {
                          }   $javafiles{'codebase'} .= '/';
                      }      }  
                  }      if (lc($tagname) eq 'applet' ||
             }, "tagname, attr"],   lc($tagname) eq 'object' ||
         text_h =>   (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')
              [sub {   ) {
                  my ($text) = @_;   foreach my $item (keys(%javafiles)) {
         }, "dtext"],      if ($item ne 'codebase' && $javafiles{$item} ne '') {
         end_h =>   my $file=$javafiles{'codebase'}.$javafiles{$item};
                [sub {   &add_filetype($allfiles,$file,$item);
                    my ($tagname) = @_;      }
                    unless ($javafiles{'codebase'} eq '') {   }
                        $javafiles{'codebase'} .= '/';      } 
                    }        pop @state;
                    if (lc($tagname) eq 'object') {   }
                        &extract_java_items(\%javafiles,$allfiles,$codebase);      }
                    }   
                    if (lc($tagname) eq 'embed') {  
                        unless (lc($state[-2]) eq 'object') {  
                            &extract_java_items(\%javafiles,$allfiles,$codebase);  
                        }  
                    }  
                    pop @state;  
                 }, "tagname"],  
     );  
     $p->parse_file($filepath.'/'.$file);  
     $p->eof;  
     return 'ok';      return 'ok';
 }  }
   
 sub extract_java_items {  sub add_filetype {
     my ($javafiles,$allfiles,$codebase) = @_;      my ($allfiles,$file,$type)=@_;
     foreach my $item (keys(%{$javafiles})) {      if (exists($allfiles->{$file})) {
         if ($item ne 'codebase') {   unless (grep/^\Q$type\E$/, @{$allfiles->{$file}}) {
             if ($$javafiles{$item} ne '') {      push(@{$allfiles->{$file}}, &escape($type));
  my $file=$javafiles->{'codebase'}.$javafiles->{$item};   }
                 if (exists($allfiles->{$file})) {      } else {
                     unless (scalar(grep(/^$item$/, @{$allfiles->{$file}}))) {   @{$allfiles->{$file}} = (&escape($type));
                         push(@{$allfiles->{$file}}, &escape($item));  
     }  
  } else {  
                     @{$allfiles->{$file}} = (&escape($item));  
                     $codebase->{$file} = $javafiles->{'codebase'};  
                 }  
             }  
         }  
     }      }
 }  }
   
Line 2920  sub allowed { Line 2901  sub allowed {
   
 # Free bre access to user's own portfolio contents  # Free bre access to user's own portfolio contents
     my ($space,$domain,$name,$dir)=split('/',$uri);      my ($space,$domain,$name,$dir)=split('/',$uri);
     if (($space=~/^(uploaded|ediupload)$/) && ($env{'user.name'} eq $name) &&       if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && 
  ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {   ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {
         return 'F';          return 'F';
     }      }
Line 3007  sub allowed { Line 2988  sub allowed {
   
 # If this is generating or modifying users, exit with special codes  # If this is generating or modifying users, exit with special codes
   
     if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:\Q$priv\E\:/) {      if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) {
    if (($priv eq 'cca') || ($priv eq 'caa')) {
       my ($audom,$auname)=split('/',$uri);
   # no author name given, so this just checks on the general right to make a co-author in this domain
       unless ($auname) { return $thisallowed; }
   # an author name is given, so we are about to actually make a co-author for a certain account
       if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) ||
    (($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) &&
    ($audom ne $env{'request.role.domain'}))) { return ''; }
    }
  return $thisallowed;   return $thisallowed;
     }      }
 #  #
Line 4084  sub unmark_as_readonly { Line 4074  sub unmark_as_readonly {
     my ($tmp)=keys(%current_permissions);      my ($tmp)=keys(%current_permissions);
     if ($tmp=~/^error:/) { undef(%current_permissions); }      if ($tmp=~/^error:/) { undef(%current_permissions); }
     my @readonly_files = &get_marked_as_readonly($domain,$user,$what);      my @readonly_files = &get_marked_as_readonly($domain,$user,$what);
     foreach my $file(@readonly_files){      foreach my $file (@readonly_files) {
         my $current_locks = $current_permissions{$file};   if (defined($file_name) && ($file_name ne $file)) { next; }
    my $current_locks = $current_permissions{$file};
         my @new_locks;          my @new_locks;
         my @del_keys;          my @del_keys;
         if (ref($current_locks) eq "ARRAY"){          if (ref($current_locks) eq "ARRAY"){
             foreach my $locker (@{$current_locks}) {              foreach my $locker (@{$current_locks}) {
                 my $compare=$locker;                  my $compare=$locker;
                 if (ref($locker)) { $compare=join('',@{$locker}) };                  if (ref($locker)) { $compare=join('',@{$locker}) };
                 if ($compare eq $symb_crs) {                  if ($compare ne $symb_crs) {
                     if (defined($file_name) && ($file_name ne $file)) {                      push(@new_locks, $locker);
                         push(@new_locks, $what);  
                     }  
                 } else {  
                     push(@new_locks, $what);  
                 }                  }
             }              }
             if (@new_locks > 0) {              if (scalar(@new_locks) > 0) {
                 $current_permissions{$file} = \@new_locks;                  $current_permissions{$file} = \@new_locks;
             } else {              } else {
                 push(@del_keys, $file);                  push(@del_keys, $file);
                 &del('file_permissions',\@del_keys, $domain, $user);                  &del('file_permissions',\@del_keys, $domain, $user);
                 delete $current_permissions{$file};                  delete($current_permissions{$file});
             }              }
         }          }
     }      }
Line 4915  sub metadata_generate_part0 { Line 4902  sub metadata_generate_part0 {
    '.type'};     '.type'};
       my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.        my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
      '.display'};       '.display'};
       my $expr='\\[Part: '.$allnames{$name}.'\\]';        my $expr='[Part: '.$allnames{$name}.']';
       $olddis=~s/\Q$expr\E/\[Part: 0\]/;        $olddis=~s/\Q$expr\E/\[Part: 0\]/;
       $$metacache{"$key.display"}=$olddis;        $$metacache{"$key.display"}=$olddis;
     }      }
Line 5020  sub symbverify { Line 5007  sub symbverify {
         if ($ids) {          if ($ids) {
 # ------------------------------------------------------------------- Has ID(s)  # ------------------------------------------------------------------- Has ID(s)
     foreach (split(/\,/,$ids)) {      foreach (split(/\,/,$ids)) {
                my ($mapid,$resid)=split(/\./,$_);         my ($mapid,$resid)=split(/\./,$_);
                if (                 if (
   &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)    &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
    eq $symb) {      eq $symb) { 
Line 5654  sub filelocation { Line 5641  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=~m:^/home/[^/]*/public_html/:) {
    # is a correct contruction space reference
           $location = $file;
     } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file      } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
         my ($udom,$uname,$filename)=          my ($udom,$uname,$filename)=
      ($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-);       ($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-);
Line 5890  BEGIN { Line 5880  BEGIN {
     }      }
     close($config);      close($config);
     # FIXME: dev server don't want this, production servers _do_ want this      # FIXME: dev server don't want this, production servers _do_ want this
     #&get_iphost();      &get_iphost();
 }  }
   
 sub get_iphost {  sub get_iphost {
Removed from v.1.638  
changed lines
  Added in v.1.650.2.1

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