Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.637 and 1.651.2.5

version 1.637, 2005/06/11 13:38:47 version 1.651.2.5, 2005/09/26 22:16:58
Line 1132  sub allowuploaded { Line 1132  sub allowuploaded {
 }  }
   
 # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course  # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
 # input: action, courseID, current domain, home server for course, intended  # input: action, courseID, current domain, intended
 #        path to file, source of file, instruction to parse file for objects,  #        path to file, source of file, instruction to parse file for objects,
 #        ref to hash for embedded objects,  #        ref to hash for embedded objects,
 #        ref to hash for codebase of java objects.  #        ref to hash for codebase of java objects.
Line 1162  sub allowuploaded { Line 1162  sub allowuploaded {
 #  #
   
 sub process_coursefile {  sub process_coursefile {
     my ($action,$docuname,$docudom,$docuhome,$file,$source,$parser,$allfiles,$codebase)=@_;      my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase)=@_;
     my $fetchresult;      my $fetchresult;
       my $home=&homeserver($docuname,$docudom);
     if ($action eq 'propagate') {      if ($action eq 'propagate') {
         $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file          $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
                             ,$docuhome);       $home);
     } else {      } else {
         my $fetchresult = '';          my $fetchresult = '';
         my $fpath = '';          my $fpath = '';
Line 1182  sub process_coursefile { Line 1183  sub process_coursefile {
                 my $destination = $filepath.'/'.$fname;                  my $destination = $filepath.'/'.$fname;
                 rename($source,$destination);                  rename($source,$destination);
                 $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,                  $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
                                  $docuhome);                                   $home);
             }              }
         } elsif ($action eq 'uploaddoc') {          } elsif ($action eq 'uploaddoc') {
             open(my $fh,'>'.$filepath.'/'.$fname);              open(my $fh,'>'.$filepath.'/'.$fname);
Line 1195  sub process_coursefile { Line 1196  sub process_coursefile {
                 }                  }
             }              }
             $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,              $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
                                  $docuhome);                                   $home);
             if ($fetchresult eq 'ok') {              if ($fetchresult eq 'ok') {
                 return '/uploaded/'.$fpath.'/'.$fname;                  return '/uploaded/'.$fpath.'/'.$fname;
             } else {              } else {
                 &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.                  &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
                         ' to host '.$docuhome.': '.$fetchresult);                          ' to host '.$home.': '.$fetchresult);
                 return '/adm/notfound.html';                  return '/adm/notfound.html';
             }              }
         }          }
     }      }
     unless ( $fetchresult eq 'ok') {      unless ( $fetchresult eq 'ok') {
         &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.          &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
              ' to host '.$docuhome.': '.$fetchresult);               ' to host '.$home.': '.$fetchresult);
     }      }
     return $fetchresult;      return $fetchresult;
 }  }
Line 1228  sub build_filepath { Line 1229  sub build_filepath {
 }  }
   
 sub store_edited_file {  sub store_edited_file {
     my ($primary_url,$content,$docudom,$docuname,$docuhome,$fetchresult) = @_;      my ($primary_url,$content,$docudom,$docuname,$fetchresult) = @_;
     my $file = $primary_url;      my $file = $primary_url;
     $file =~ s#^/uploaded/$docudom/$docuname/##;      $file =~ s#^/uploaded/$docudom/$docuname/##;
     my $fpath = '';      my $fpath = '';
Line 1239  sub store_edited_file { Line 1240  sub store_edited_file {
     open(my $fh,'>'.$filepath.'/'.$fname);      open(my $fh,'>'.$filepath.'/'.$fname);
     print $fh $content;      print $fh $content;
     close($fh);      close($fh);
       my $home=&homeserver($docuname,$docudom);
     $$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,      $$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
                                  $docuhome);    $home);
     if ($$fetchresult eq 'ok') {      if ($$fetchresult eq 'ok') {
         return '/uploaded/'.$fpath.'/'.$fname;          return '/uploaded/'.$fpath.'/'.$fname;
     } else {      } else {
         &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.                        ' to host '.$docuhome.': '.$$fetchresult);          &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
    ' to host '.$home.': '.$$fetchresult);
         return '/adm/notfound.html';          return '/adm/notfound.html';
     }      }
 }  }
Line 1295  sub userfileupload { Line 1298  sub userfileupload {
         return $fullpath.'/'.$fname;           return $fullpath.'/'.$fname; 
     }      }
 # Create the directory if not present  # Create the directory if not present
     my $docuname='';  
     my $docudom='';  
     my $docuhome='';  
     $fname="$subdir/$fname";      $fname="$subdir/$fname";
     if ($coursedoc) {      if ($coursedoc) {
  $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};   my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
  $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};   my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
  $docuhome=$env{'course.'.$env{'request.course.id'}.'.home'};          if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
         if ($env{'form.folder'} =~ m/^default/) {              return &finishuserfileupload($docuname,$docudom,
             return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname,$parser,$allfiles,$codebase);   $formname,$fname,$parser,$allfiles,
    $codebase);
         } else {          } else {
             $fname=$env{'form.folder'}.'/'.$fname;              $fname=$env{'form.folder'}.'/'.$fname;
             return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname,$parser,$allfiles,$codebase);              return &process_coursefile('uploaddoc',$docuname,$docudom,
          $fname,$formname,$parser,
          $allfiles,$codebase);
         }          }
     } else {      } else {
         $docuname=$env{'user.name'};          my $docuname=$env{'user.name'};
         $docudom=$env{'user.domain'};          my $docudom=$env{'user.domain'};
         $docuhome=$env{'user.home'};   return &finishuserfileupload($docuname,$docudom,$formname,
         return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname,$parser,$allfiles,$codebase);       $fname,$parser,$allfiles,$codebase);
     }      }
 }  }
   
 sub finishuserfileupload {  sub finishuserfileupload {
     my ($docuname,$docudom,$docuhome,$formname,$fname,$parser,$allfiles,$codebase) = @_;      my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_;
     my $path=$docudom.'/'.$docuname.'/';      my $path=$docudom.'/'.$docuname.'/';
     my $filepath=$perlvar{'lonDocRoot'};      my $filepath=$perlvar{'lonDocRoot'};
     my ($fnamepath,$file);      my ($fnamepath,$file);
Line 1342  sub finishuserfileupload { Line 1345  sub finishuserfileupload {
  close(FH);   close(FH);
     }      }
     if ($parser eq 'parse') {      if ($parser eq 'parse') {
         my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,$codebase);          my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,
      $codebase);
         unless ($parse_result eq 'ok') {          unless ($parse_result eq 'ok') {
             &logthis('Failed to parse '.$filepath.$file.' for embedded media: '.$parse_result);               &logthis('Failed to parse '.$filepath.$file.
        ' for embedded media: '.$parse_result); 
         }          }
     }      }
 # Notify homeserver to grep it  # Notify homeserver to grep it
 #  #
       my $docuhome=&homeserver($docuname,$docudom);
     my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);      my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
     if ($fetchresult eq 'ok') {      if ($fetchresult eq 'ok') {
 #  #
Line 1362  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 1373  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');
                      }  
                  }  
                  if (lc($state[-2]) eq 'object') {  
                      if (lc($tagname) eq 'param') {  
                          my $name = lc($attr->{'name'});  
                          foreach my $item (keys (%mediafiles)) {  
                              if ($name eq $item) {  
                                  if (exists($$allfiles{$attr->{'value'}})) {  
                                      unless(grep/^value$/,@{$$allfiles{$attr->{'value'}}}) {  
                                          push(@{$$allfiles{$attr->{'value'}}},&escape('value'));  
                                      }  
                                  } else {  
                                      @{$$allfiles{$attr->{'value'}}} = (&escape('value'));  
                                  }  
                                  last;  
                              }  
                          }  
                          foreach my $item (keys (%javafiles)) {  
                              if ($name eq $item) {  
                                  $javafiles{$item} = $attr->{'value'};  
                                  last;  
                              }  
                          }  
                      }  
                  }  
                  if (lc($tagname) eq 'embed') {  
                      unless (lc($state[-2]) eq 'object') {  
                          foreach my $item (keys (%javafiles)) {  
                              $javafiles{$item} = '';  
                          }  
                      }  
                      foreach my $item (keys (%javafiles)) {  
                          if ($attr->{$item}) {  
                              $javafiles{$item} = $attr->{$item};  
                              last;  
                          }  
                      }  
                      foreach my $item (keys (%mediafiles)) {  
                          if ($attr->{$item}) {  
                              if (exists($$allfiles{$attr->{$item}})) {  
                                  unless (grep/^$item$/,@{$$allfiles{$item}}) {  
                                      push(@{$$allfiles{$attr->{$item}}},&escape($item));  
                                  }  
                              } else {  
                                  @{$$allfiles{$attr->{$item}}} = (&escape($item));  
                              }  
                              last;  
                          }  
                      }  
                  }  
             }, "tagname, attr"],  
         text_h =>  
              [sub {  
                  my ($text) = @_;  
         }, "dtext"],  
         end_h =>  
                [sub {  
                    my ($tagname) = @_;  
                    unless ($javafiles{'codebase'} eq '') {  
                        $javafiles{'codebase'} .= '/';  
                    }    
                    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';  
 }  
   
 sub extract_java_items {  
     my ($javafiles,$allfiles,$codebase) = @_;  
     foreach my $item (keys (%{$javafiles})) {  
         unless ($item eq 'codebase') {  
             if ($$javafiles{$item} ne '') {  
                 if (exists($$allfiles{$$javafiles{'codebase'}.$$javafiles{$item}})) {  
                     unless (grep/^$item$/,@{$$allfiles{$$javafiles{'codebase'}.$$javafiles{$item}}}) {  
                         push(@{$$allfiles{$$javafiles{'codebase'}.$$javafiles{$item}}},&escape($item));  
                     }  
                 } else {                  } else {
                     @{$$allfiles{$$javafiles{'codebase'}.$$javafiles{$item}}} = (&escape($item));                      &add_filetype($allfiles,$attr->{'src'},'src');
                     $$codebase{$$javafiles{'codebase'}.$$javafiles{$item}} = $$javafiles{'codebase'};  
                                                                                   
                 }                  }
             }              }
         }              if (lc($tagname) eq 'link') {
                   if (lc($attr->{'rel'}) eq 'stylesheet') { 
                       &add_filetype($allfiles,$attr->{'href'},'href');
                   }
               }
       if (lc($tagname) eq 'object' ||
    (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')) {
    foreach my $item (keys(%javafiles)) {
       $javafiles{$item} = '';
    }
       }
       if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {
    my $name = lc($attr->{'name'});
    foreach my $item (keys(%javafiles)) {
       if ($name eq $item) {
    $javafiles{$item} = $attr->{'value'};
    last;
       }
    }
    foreach my $item (keys(%mediafiles)) {
       if ($name eq $item) {
    &add_filetype($allfiles, $attr->{'value'}, 'value');
    last;
       }
    }
       }
       if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {
    foreach my $item (keys(%javafiles)) {
       if ($attr->{$item}) {
    $javafiles{$item} = $attr->{$item};
    last;
       }
    }
    foreach my $item (keys(%mediafiles)) {
       if ($attr->{$item}) {
    &add_filetype($allfiles,$attr->{$item},$item);
    last;
       }
    }
       }
    } elsif ($t->[0] eq 'E') {
       my ($tagname) = ($t->[1]);
       if ($javafiles{'codebase'} ne '') {
    $javafiles{'codebase'} .= '/';
       }  
       if (lc($tagname) eq 'applet' ||
    lc($tagname) eq 'object' ||
    (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')
    ) {
    foreach my $item (keys(%javafiles)) {
       if ($item ne 'codebase' && $javafiles{$item} ne '') {
    my $file=$javafiles{'codebase'}.$javafiles{$item};
    &add_filetype($allfiles,$file,$item);
       }
    }
       } 
       pop @state;
    }
       }
       return 'ok';
   }
   
   sub add_filetype {
       my ($allfiles,$file,$type)=@_;
       if (exists($allfiles->{$file})) {
    unless (grep/^\Q$type\E$/, @{$allfiles->{$file}}) {
       push(@{$allfiles->{$file}}, &escape($type));
    }
       } else {
    @{$allfiles->{$file}} = (&escape($type));
     }      }
 }  }
   
Line 1649  sub courseacclog { Line 1636  sub courseacclog {
     my $fnsymb=shift;      my $fnsymb=shift;
     unless ($env{'request.course.id'}) { return ''; }      unless ($env{'request.course.id'}) { return ''; }
     my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};      my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};
     if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) {      if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) {
         $what.=':POST';          $what.=':POST';
         # FIXME: Probably ought to escape things....          # FIXME: Probably ought to escape things....
  foreach (keys %env) {   foreach (keys %env) {
Line 1722  sub get_course_adv_roles { Line 1709  sub get_course_adv_roles {
  if ($username eq '' || $domain eq '') { next; }   if ($username eq '' || $domain eq '') { next; }
  if ((&privileged($username,$domain)) &&    if ((&privileged($username,$domain)) && 
     (!$nothide{$username.':'.$domain})) { next; }      (!$nothide{$username.':'.$domain})) { next; }
    if ($role eq 'cr') { next; }
         my $key=&plaintext($role);          my $key=&plaintext($role);
    if ($role =~ /^cr/) {
       $key=(split('/',$role))[3];
    }
         if ($section) { $key.=' (Sec/Grp '.$section.')'; }          if ($section) { $key.=' (Sec/Grp '.$section.')'; }
         if ($returnhash{$key}) {          if ($returnhash{$key}) {
     $returnhash{$key}.=','.$username.':'.$domain;      $returnhash{$key}.=','.$username.':'.$domain;
Line 2491  sub rolesinit { Line 2482  sub rolesinit {
           
             my ($trole,$tend,$tstart);              my ($trole,$tend,$tstart);
     if ($role=~/^cr/) {       if ($role=~/^cr/) { 
  ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|);   if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) {
  ($tend,$tstart)=split('_',$trest);      ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|);
       ($tend,$tstart)=split('_',$trest);
    } else {
       $trole=$role;
    }
     } else {      } else {
  ($trole,$tend,$tstart)=split(/_/,$role);   ($trole,$tend,$tstart)=split(/_/,$role);
     }      }
Line 2914  sub allowed { Line 2909  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 3001  sub allowed { Line 2996  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 3875  sub createcourse { Line 3879  sub createcourse {
 </map>  </map>
 ENDINITMAP  ENDINITMAP
         $topurl=&declutter(          $topurl=&declutter(
         &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence')          &finishuserfileupload($uname,$udom,'initmap','default.sequence')
                           );                            );
     }      }
 # ----------------------------------------------------------- Write preferences  # ----------------------------------------------------------- Write preferences
Line 4078  sub unmark_as_readonly { Line 4082  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 4427  sub EXT { Line 4428  sub EXT {
     if ($realm eq 'user') {      if ($realm eq 'user') {
 # --------------------------------------------------------------- user.resource  # --------------------------------------------------------------- user.resource
  if ($space eq 'resource') {   if ($space eq 'resource') {
     if (defined($Apache::lonhomework::parsing_a_problem) ||      if ( (defined($Apache::lonhomework::parsing_a_problem)
  defined($Apache::lonhomework::parsing_a_task)) {    || defined($Apache::lonhomework::parsing_a_task))
    &&
    ($symbparm eq &symbread()) ) {
  return $Apache::lonhomework::history{$qualifierrest};   return $Apache::lonhomework::history{$qualifierrest};
     } else {      } else {
  my %restored;   my %restored;
Line 4857  sub metadata { Line 4860  sub metadata {
  $metaentry{':keys'}=join(',',keys %metathesekeys);   $metaentry{':keys'}=join(',',keys %metathesekeys);
  &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);   &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
  $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);   $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
  &do_cache_new('meta',$uri,\%metaentry,60*60*24);   &do_cache_new('meta',$uri,\%metaentry,600);
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metaentry{':'.$what};      return $metaentry{':'.$what};
Line 4909  sub metadata_generate_part0 { Line 4912  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 5014  sub symbverify { Line 5017  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 5648  sub filelocation { Line 5651  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 5884  BEGIN { Line 5890  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 {
     if (%iphost) { return %iphost; }      if (%iphost) { return %iphost; }
       my %name_to_ip;
     foreach my $id (keys(%hostname)) {      foreach my $id (keys(%hostname)) {
  my $name=$hostname{$id};   my $name=$hostname{$id};
  my $ip = gethostbyname($name);   my $ip;
  if (!$ip || length($ip) ne 4) {   if (!exists($name_to_ip{$name})) {
     &logthis("Skipping host $id name $name no IP found\n");      $ip = gethostbyname($name);
     next;      if (!$ip || length($ip) ne 4) {
    &logthis("Skipping host $id name $name no IP found\n");
    next;
       }
       $ip=inet_ntoa($ip);
       $name_to_ip{$name} = $ip;
    } else {
       $ip = $name_to_ip{$name};
  }   }
  $ip=inet_ntoa($ip);  
  push(@{$iphost{$ip}},$id);   push(@{$iphost{$ip}},$id);
     }      }
     return %iphost;      return %iphost;
Line 6798  userspace, probably shouldn't be called Line 6811  userspace, probably shouldn't be called
   
   docuname: username or courseid of destination for the file    docuname: username or courseid of destination for the file
   docudom: domain of user/course of destination for the file    docudom: domain of user/course of destination for the file
   docuhome: loncapa id of the library server that is getting the file  
   formname: same as for userfileupload()    formname: same as for userfileupload()
   fname: filename (inculding subdirectories) for the file    fname: filename (inculding subdirectories) for the file
   

Removed from v.1.637  
changed lines
  Added in v.1.651.2.5


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