Original release 20160328

[fex.git] / lib / dop

diff --git a/lib/dop b/lib/dop
index d8166247c3f922e5256debb874e649aa21b97a63..dc92d7008fdd07f6a2fb43080ccb06f0a513689b 100755 (executable)
--- a/lib/dop
+++ b/lib/dop
@@ -12,6 +12,7 @@ use CGI::Carp qw(fatalsToBrowser);
 use Fcntl      qw(:flock :seek :mode);
 use POSIX      qw(strftime locale_h);
 use Cwd        qw(getcwd abs_path);
 use Fcntl      qw(:flock :seek :mode);
 use POSIX      qw(strftime locale_h);
 use Cwd        qw(getcwd abs_path);

+use utf8;

 
 # import from fex.pp
 our ($bs,$tmpdir,@doc_dirs);
 
 # import from fex.pp
 our ($bs,$tmpdir,@doc_dirs);


@@ -27,31 +28,29 @@ sub dop {
   my $seek = 0;
   my $stop = 0;
   my ($link,$host,$path,$range);
   my $seek = 0;
   my $stop = 0;
   my ($link,$host,$path,$range);

-  
+

   our $error = 'F*EX document output ERROR';
   our $error = 'F*EX document output ERROR';

-  
+

   security_check($doc);
   security_check($doc);

-  
+

   # reget?
   if ($range = $ENV{HTTP_RANGE}) {
     $seek = $1 if $range =~ /^bytes=(\d+)-/i;
     $stop = $1 if $range =~ /^bytes=\d*-(\d+)/i;
   }
 
   # reget?
   if ($range = $ENV{HTTP_RANGE}) {
     $seek = $1 if $range =~ /^bytes=(\d+)-/i;
     $stop = $1 if $range =~ /^bytes=\d*-(\d+)/i;
   }
 

-  # redirect on relative symlinks without "../" 
-  if ($link = readlink($doc) and 
+  # redirect on relative symlinks without "../"
+  if ($link = readlink($doc) and

       $link !~ m:^/: and $link !~ m:\.\./: and $link !~ /^:.+:$/) {
     $path = $ENV{REQUEST_URI};
     $path =~ s:[^/]*$::;
     $doc = "$path/$link";
     $doc =~ s:/+:/:g;
     $doc =~ s:^/::;
       $link !~ m:^/: and $link !~ m:\.\./: and $link !~ /^:.+:$/) {
     $path = $ENV{REQUEST_URI};
     $path =~ s:[^/]*$::;
     $doc = "$path/$link";
     $doc =~ s:/+:/:g;
     $doc =~ s:^/::;

-    $host = $ENV{HTTP_HOST} || $hostname;

     nvt_print(
     nvt_print(

-      "HTTP/1.1 301 Moved Permanently",
-      "Location: $ENV{PROTO}://$host/$doc",
+      "HTTP/1.1 302 Found",
+      "Location: /$doc",

       "Content-Length: 0",
       "Content-Length: 0",

-      "Connection: close",

       ""
     );
     &reexec;
       ""
     );
     &reexec;


@@ -99,10 +98,11 @@ sub http_output {
   } elsif ($file =~ /(.+)\.tgz$/ and -f "$1.tar") {
     @files = ("$1.tar");
     open $file,'-|',qw'gzip -c',@files or http_error(503);
   } elsif ($file =~ /(.+)\.tgz$/ and -f "$1.tar") {
     @files = ("$1.tar");
     open $file,'-|',qw'gzip -c',@files or http_error(503);

-  } elsif ($file =~ /(.+)\.(tar|tgz|zip)$/ and 
-           @s = lstat($streamfile = "$1.stream") and $s[4] == $<)
+  } elsif ($file =~ /(.+)\.(tar|tgz|zip)$/ and
+           @s = lstat($streamfile = "$1.stream") and
+           ($s[4] == $< or $s[4] == 0))

   {
   {

-    # streaming file (only if it is owned by user fex)
+    # streaming file

     chdir dirname($file);
     security_check($file);
     if (-l $streamfile and readlink($streamfile) =~ /^:(.+):$/) {
     chdir dirname($file);
     security_check($file);
     if (-l $streamfile and readlink($streamfile) =~ /^:(.+):$/) {


@@ -124,18 +124,18 @@ sub http_output {
     }
     close $streamfile;
     foreach (@files) {
     }
     close $streamfile;
     foreach (@files) {

-      if (/^\// or /\.\.\//) { 
+      if (/^\// or /\.\.\//) {

         # absolute path or relative path with parent directory is not allowed
         http_error(403);
       }
         # absolute path or relative path with parent directory is not allowed
         http_error(403);
       }

-      if (@s = stat($_) and not($s[2] & S_IRGRP) or not -r $_) { 
+      if (@s = stat($_) and not($s[2] & S_IRGRP) or not -r $_) {

         # file must be readable by user and group
         http_error(403);
       }
     }
     http_error(416) if $ENV{HTTP_RANGE};
     close STDERR;
         # file must be readable by user and group
         http_error(403);
       }
     }
     http_error(416) if $ENV{HTTP_RANGE};
     close STDERR;

-    if    ($file =~ /\.tar$/) { @a = qw'tar --exclude *~ --exclude .* -cf -' } 
+    if    ($file =~ /\.tar$/) { @a = qw'tar --exclude *~ --exclude .* -cf -' }

     elsif ($file =~ /\.tgz$/) { @a = qw'tar --exclude *~ --exclude .* -czf -' }
     elsif ($file =~ /\.zip$/) { @a = qw'zip -x *~ */.*/* @ -rq -' }
     else { http_error(400) }
     elsif ($file =~ /\.tgz$/) { @a = qw'tar --exclude *~ --exclude .* -czf -' }
     elsif ($file =~ /\.zip$/) { @a = qw'zip -x *~ */.*/* @ -rq -' }
     else { http_error(400) }


@@ -143,9 +143,9 @@ sub http_output {
   } else {
     http_error(404);
   }
   } else {
     http_error(404);
   }

-  
+

   $type = 'application/octet-stream';
   $type = 'application/octet-stream';

-  if    ($file =~ /\.html$/)   { $type = 'text/html' } 
+  if    ($file =~ /\.html$/)   { $type = 'text/html' }

   # elsif ($file =~ /\.txt$/)  { $type = 'text/plain' }
   elsif ($file =~ /\.css$/)    { $type = 'text/css' }
   elsif ($file =~ /\.js$/)     { $type = 'text/javascript' }
   # elsif ($file =~ /\.txt$/)  { $type = 'text/plain' }
   elsif ($file =~ /\.css$/)    { $type = 'text/css' }
   elsif ($file =~ /\.js$/)     { $type = 'text/javascript' }


@@ -181,8 +181,8 @@ sub http_output {
   } elsif ($ENV{'QUERY_STRING'} eq '!') {
     $type = 'text/plain';
   }
   } elsif ($ENV{'QUERY_STRING'} eq '!') {
     $type = 'text/plain';
   }

-      
-  
+
+

   if ($type eq 'text/html') {
     $seek = $stop = 0;
     local $^W = 0;
   if ($type eq 'text/html') {
     $seek = $stop = 0;
     local $^W = 0;


@@ -223,15 +223,31 @@ sub http_output {
       }
       $dynamic = $htmldoc =~ s/$mark/$include/;
     }
       }
       $dynamic = $htmldoc =~ s/$mark/$include/;
     }

-    # evaluate <<perl-code>>
-    while ($htmldoc =~ /<<(.+?)>>/s) {
-      local $pc = $1;
-      local $__ = '';
-      tie *STDOUT => "Buffer",\$__;
-      $__ .= eval $pc;
-      untie *STDOUT;
-      $dynamic = $htmldoc =~ s/<<(.+?)>>/$__/s;
-    };
+    # evaluate <<perl-code>> or <<<perl-code>>>
+    {
+      local $timeout = '';
+      local $SIG{ALRM} = sub { $timeout = '<h3>TIMEOUT!</h3>' };
+      alarm(10);
+      while ($htmldoc =~ /<<(.+?>?)>>/s) {
+        local $pc = $1;
+        if ($pc =~ s/^<(.+)>$/$1/) {
+          # eval code without output substitution
+          eval('package DOP;' . $pc);
+          last if $timeout;
+          $dynamic = $htmldoc =~ s/<<<(.+?)>>>//s;
+        } else {
+          # eval code with output substitution
+          local $__ = '';
+          tie *STDOUT => "Buffer",\$__;
+          $__ .= eval('package DOP;' . $pc);
+          untie *STDOUT;
+          last if $timeout;
+          $dynamic = $htmldoc =~ s/<<(.+?)>>/$__/s;
+        }
+      }
+      alarm(0);
+      $dynamic = $htmldoc =~ s/<<(.+?>?)>>/$timeout/sg if $timeout;
+    }

     # substitute $variable$ with value from environment (if present)
     while ($htmldoc =~ /\$([\w_]+)\$/g) {
       $var = $1;
     # substitute $variable$ with value from environment (if present)
     while ($htmldoc =~ /\$([\w_]+)\$/g) {
       $var = $1;


@@ -253,9 +269,9 @@ sub http_output {
     http_header('416 Requested Range Not Satisfiable');
     exit;
   }
     http_header('416 Requested Range Not Satisfiable');
     exit;
   }

-  
+

   alarm($timeout*10);
   alarm($timeout*10);

-  
+

   if ($seek or $stop) {
     my $range;
     if ($stop) {
   if ($seek or $stop) {
     my $range;
     if ($stop) {


@@ -269,7 +285,6 @@ sub http_output {
       "Content-Length: $size",
       "Content-Range: $range",
       "Content-Type: $type",
       "Content-Length: $size",
       "Content-Range: $range",
       "Content-Type: $type",

-      '',

     );
   } else {
     # streaming?
     );
   } else {
     # streaming?


@@ -279,7 +294,6 @@ sub http_output {
         'Server: fexsrv',
         "Expires: 0",
         "Content-Type: $type",
         'Server: fexsrv',
         "Expires: 0",
         "Content-Type: $type",

-        '',

       );
     } else {
       # Java (clients) needs Last-Modified header!
       );
     } else {
       # Java (clients) needs Last-Modified header!


@@ -298,10 +312,11 @@ sub http_output {
         "Content-Length: $size",
         "Content-Type: $type",
       );
         "Content-Length: $size",
         "Content-Type: $type",
       );

-      nvt_print("Set-Cookie: locale=$locale") if $use_cookies and $locale;
-      nvt_print('');
+      # nvt_print("Set-Cookie: locale=$locale") if $use_cookies and $locale;

     }
   }
     }
   }

+  nvt_print($_) foreach(@extra_header);
+  nvt_print('');

 
   if ($ENV{REQUEST_METHOD} eq 'GET') {
     if ($type eq 'text/html') {
 
   if ($ENV{REQUEST_METHOD} eq 'GET') {
     if ($type eq 'text/html') {


@@ -316,14 +331,14 @@ sub http_output {
           $b = $size-$s;
           $data = substr($data,0,$b)
         }
           $b = $size-$s;
           $data = substr($data,0,$b)
         }

-        $s += $b;      
+        $s += $b;

         alarm($timeout*10);
         print $data or last;
       }
     }
     fdlog($log,$file,$s,$size) if $s;
   }
         alarm($timeout*10);
         print $data or last;
       }
     }
     fdlog($log,$file,$s,$size) if $s;
   }

-  
+

   alarm(0);
   close $file;
   exit if @files; # streaming end
   alarm(0);
   close $file;
   exit if @files; # streaming end


@@ -342,22 +357,22 @@ sub showindex {
   my $allowed;
   my ($htindex,$htauth);
   local $_;
   my $allowed;
   my ($htindex,$htauth);
   local $_;

-  
+

   $uri =~ s:/+$::;
   $dir =~ s:/+$::;
 
   security_check($dir);
   $uri =~ s:/+$::;
   $dir =~ s:/+$::;
 
   security_check($dir);

-  
+

   $htindex = "$dir/.htindex";
   $htauth  = "$dir/.htauth";
   $htindex = "$dir/.htindex";
   $htauth  = "$dir/.htauth";

-  
+

   open $htindex,$htindex or http_error(403);
   require_auth($htauth,$dir) if -f $htauth;
   open $htindex,$htindex or http_error(403);
   require_auth($htauth,$dir) if -f $htauth;

-  
+

   # .htindex may contain listing regexp
   chomp ($allowed = <$htindex>||'.');
   close $htindex;
   # .htindex may contain listing regexp
   chomp ($allowed = <$htindex>||'.');
   close $htindex;

-  
+

   opendir $dir,$dir or http_error(503);
   while (defined($_ = readdir $dir)) {
     next if /^[.#]/ or /~$/;
   opendir $dir,$dir or http_error(503);
   while (defined($_ = readdir $dir)) {
     next if /^[.#]/ or /~$/;


@@ -383,7 +398,7 @@ sub showindex {
       $htmldoc .= "<h3><a href=\"$uri/$d/\">$uri/$d/</a></h3>\n";
     }
   }
       $htmldoc .= "<h3><a href=\"$uri/$d/\">$uri/$d/</a></h3>\n";
     }
   }

-  
+

 #  # then the symlinks
 #  $htmldoc .= "\n<pre>\n";
 #  my $link;
 #  # then the symlinks
 #  $htmldoc .= "\n<pre>\n";
 #  my $link;


@@ -392,7 +407,7 @@ sub showindex {
 #      $htmldoc .= "$l -> <a href=\"$link\">$dir/$link</a>\n";
 #    }
 #  }
 #      $htmldoc .= "$l -> <a href=\"$link\">$dir/$link</a>\n";
 #    }
 #  }

-  
+

   # then the files
   $htmldoc .= "\n<pre>\n";
   foreach my $f (sort @files) {
   # then the files
   $htmldoc .= "\n<pre>\n";
   foreach my $f (sort @files) {


@@ -404,7 +419,7 @@ sub showindex {
     }
   }
   $htmldoc .= "</pre>\n</HTML>\n";
     }
   }
   $htmldoc .= "</pre>\n</HTML>\n";

-  
+

   $size = length($htmldoc);
   nvt_print(
     'HTTP/1.1 200 OK',
   $size = length($htmldoc);
   nvt_print(
     'HTTP/1.1 200 OK',


@@ -428,7 +443,7 @@ sub d3 {
 sub http_date {
   my $file = shift;
   my @stat;
 sub http_date {
   my $file = shift;
   my @stat;

-  
+

   if (@stat = stat($file)) {
     return strftime("%a, %d %b %Y %T GMT",gmtime($stat[9]));
   } else {
   if (@stat = stat($file)) {
     return strftime("%a, %d %b %Y %T GMT",gmtime($stat[9]));
   } else {


@@ -452,9 +467,9 @@ sub path_match {
 # return real file name (from symlink)
 sub realfilename {
   my $file = shift;
 # return real file name (from symlink)
 sub realfilename {
   my $file = shift;

-  
+

   return '' unless -e $file;
   return '' unless -e $file;

-  
+

   if (-l $file) {
     return realfilename(readlink($file));
   } else {
   if (-l $file) {
     return realfilename(readlink($file));
   } else {


@@ -483,13 +498,13 @@ sub security_check {
       errorlog("$file contains @");
       http_error(403);
     }
       errorlog("$file contains @");
       http_error(403);
     }

-  
+

     # document filename must not end with ~
     if (realfilename($file) =~ /~$/) {
       errorlog("$file ends with ~");
       http_error(403);
     }
     # document filename must not end with ~
     if (realfilename($file) =~ /~$/) {
       errorlog("$file ends with ~");
       http_error(403);
     }

-  
+

     # file must be group or world readable
     if (@s = stat($file) and not($s[2] & (S_IRGRP|S_IROTH))) {
       errorlog("$file not group or world readable");
     # file must be group or world readable
     if (@s = stat($file) and not($s[2] & (S_IRGRP|S_IROTH))) {
       errorlog("$file not group or world readable");


@@ -501,14 +516,14 @@ sub security_check {
       @s = lstat($file);
       return if $s[4] == 0 or $s[4] == $<;
     }
       @s = lstat($file);
       return if $s[4] == 0 or $s[4] == $<;
     }

-    
+

   }
   }

-  
+

   # file in allowed directory? ==> ok!
   foreach my $dir (@doc_dirs) {
     return if path_match($file,$dir);
   }
   # file in allowed directory? ==> ok!
   foreach my $dir (@doc_dirs) {
     return if path_match($file,$dir);
   }

-  
+

   errorlog("$file not in \@doc_dirs");
   http_error(403);
 }
   errorlog("$file not in \@doc_dirs");
   http_error(403);
 }


@@ -521,7 +536,7 @@ sub access_check {
   local $_;
 
   $dir .= '/x' if -d $dir;
   local $_;
 
   $dir .= '/x' if -d $dir;

-  
+

   while ($dir = dirname($dir) and $dir ne '/') {
     $af = "$dir/.htaccessfrom";
     if (open $af,$af) {
   while ($dir = dirname($dir) and $dir ne '/') {
     $af = "$dir/.htaccessfrom";
     if (open $af,$af) {


@@ -536,7 +551,7 @@ sub access_check {
       http_error(403);
     }
   }
       http_error(403);
     }
   }

-    
+

 }
 
 # HTTP Basic authentication
 }
 
 # HTTP Basic authentication


@@ -546,7 +561,7 @@ sub require_auth {
   my ($realm,$auth);
   my @http_auth;
   my $uri = $ENV{REQUEST_URI} || '/';
   my ($realm,$auth);
   my @http_auth;
   my $uri = $ENV{REQUEST_URI} || '/';

-  
+

   $uri =~ s/\/index\.html$//;
   $uri =~ s/\/$//;
 
   $uri =~ s/\/index\.html$//;
   $uri =~ s/\/$//;
 


@@ -555,7 +570,7 @@ sub require_auth {
   } else {
     $realm = dirname($uri);
   }
   } else {
     $realm = dirname($uri);
   }

-  
+

   $auth = slurp($htauth);
   unless ($auth and $realm) {
     http_header("200 OK");
   $auth = slurp($htauth);
   unless ($auth and $realm) {
     http_header("200 OK");


@@ -567,8 +582,8 @@ sub require_auth {
     exit;
   }
   chomp $auth;
     exit;
   }
   chomp $auth;

-  
-  if ($ENV{HTTP_AUTHORIZATION} and $ENV{HTTP_AUTHORIZATION} =~ /Basic\s+(.+)/) 
+
+  if ($ENV{HTTP_AUTHORIZATION} and $ENV{HTTP_AUTHORIZATION} =~ /Basic\s+(.+)/)

   { @http_auth = split(':',decode_b64($1)) }
   if (@http_auth != 2 or $http_auth[1] ne $auth) {
     http_header(
   { @http_auth = split(':',decode_b64($1)) }
   if (@http_auth != 2 or $http_auth[1] ne $auth) {
     http_header(


@@ -591,18 +606,18 @@ sub out {
 # tie STDOUT to buffer variable (redefining print)
 package Buffer;
 
 # tie STDOUT to buffer variable (redefining print)
 package Buffer;
 

-sub TIEHANDLE { 
-  my ($class,$buffer) = @_; 
-  bless $buffer,$class; 
+sub TIEHANDLE {
+  my ($class,$buffer) = @_;
+  bless $buffer,$class;

 }
 
 }
 

-sub PRINT { 
-  my $buffer = shift; 
-  $$buffer .= $_ foreach @_; 
+sub PRINT {
+  my $buffer = shift;
+  $$buffer .= $_ foreach @_;

 }
 
 }
 

-sub PRINTF { 
-  my $buffer = shift; 
+sub PRINTF {
+  my $buffer = shift;

   my $fmt = shift @_;
   $$buffer .= sprintf($fmt,@_);
 }
   my $fmt = shift @_;
   $$buffer .= sprintf($fmt,@_);
 }