httpd-apreq-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From j...@apache.org
Subject cvs commit: httpd-apreq/t api.pl book.gif cookie.t request-cookie.pl request-param.pl request-upload.pl request.t
Date Sun, 17 Nov 2002 23:14:22 GMT
joes        2002/11/17 15:14:22

  Added:       t        api.pl book.gif cookie.t request-cookie.pl
                        request-param.pl request-upload.pl request.t
  Log:
  Adopted modperl test files.
  
  Revision  Changes    Path
  1.1                  httpd-apreq/t/api.pl
  
  Index: api.pl
  ===================================================================
  #!perl
  use Apache ();
  use Apache::Constants qw(:server :common :methods);
  use Apache::test;
  use strict;
  
  Apache->register_cleanup(sub {0});
  my $r;
  
  if(Apache->module("Apache::Request")) {
      $r = Apache::Request->new(shift);
  }
  else {
      $r = Apache->request;
  }
  
  
  my $is_xs = ($r->uri =~ /_xs/);
  
  my $tests = 81;
  my $is_win32 = WIN32;
  $tests += 4 unless $is_win32;
  my $test_get_set = Apache->can('set_handlers') && ($tests += 4);
  my $test_custom_response = (MODULE_MAGIC_NUMBER >= 19980324) && ($tests += 4);
  my $test_dir_config = $INC{'Apache/TestDirectives.pm'} && ($tests += 9);
  
  my $i;
  
  $r->content_type("text/plain");
  $r->content_languages([qw(en)]);
  $r->no_cache(1);
  $r->send_http_header;
  
  $r->print("1..$tests\n");
  
  test ++$i, $ENV{MOD_PERL};
  print "ENV{MOD_PERL} = $ENV{MOD_PERL}\n";
  
  #backward compat
  %ENV = $r->cgi_env;
  my $envk = keys %ENV;
  #print "cgi_env ($envk):\n";
  #print map { "$_ = $ENV{$_}\n" } keys %ENV;
  
  $r->subprocess_env; #test void context
  $envk = keys %ENV;
  #print "subprocess_env ($envk):\n";
  #print map { "$_ = $ENV{$_}\n" } keys %ENV;
  
  test ++$i, $r->as_string;
  print $r->as_string;
  print "r == $r\n";
  test ++$i, $r->filename eq $0;
  test ++$i, -d $Apache::Server::CWD;
  print "\$Apache::Server::CWD == $Apache::Server::CWD\n";
  print "\$0 == $0\n";
  
  if($Apache::Server::Starting) {
      warn "Apache::ServerStarting var is broken\n";
  }
  if($Apache::Server::ReStarting) {
      warn "Apache::ReServerStarting var is broken\n";
  }
  
  unless ($is_win32) {
    my $ft_s = -s $INC{'Apache.pm'};
    $r->finfo;
    my $ft_def = -s _;
    print "Apache.pm == $ft_s, $0 == $ft_def\n";
    test ++$i, $ft_s != $ft_def;
    test ++$i, (-s $r->finfo) == $ft_def;
    test ++$i, -T $r->finfo;
    test ++$i, not -B $r->finfo;
  }
  
  my $the_request = $r->the_request;
  my $request_string = $r->method . ' ' .
                       $r->uri    . '?' .
                       $r->args   . ' ' .
                       $r->protocol; 
  $r->the_request($request_string);
  test ++$i, $the_request eq $r->the_request;
  printf "old=$the_request, new=%s\n", $r->the_request;
  $r->the_request(undef);
  test ++$i, not $r->the_request;
  test ++$i, not defined $r->the_request;
  
  my $doc_root = $r->document_root;
  $r->document_root('/tmp');
  test ++$i, $r->document_root eq '/tmp';
  $r->document_root($doc_root);
  test ++$i, $r->document_root eq $doc_root;
  
  my $loc = $r->location;
  print "<Location $loc>\n";
  test ++$i, $loc and $r->uri =~ m:^$loc:;
  
  test ++$i, $r->get_remote_host;
  test ++$i, $r->get_server_port;
  
  test ++$i, SERVER_VERSION =~ /mod_perl/;
  
  test ++$i, $r->last;
  test ++$i, $ENV{GATEWAY_INTERFACE};
  test ++$i, defined $ENV{KeyForPerlSetEnv};
  test ++$i, scalar $r->cgi_var('GATEWAY_INTERFACE');
  test ++$i, defined($r->seqno);
  test ++$i, $r->protocol;
  #hostname
  test ++$i, $r->status;
  test ++$i, $r->status_line;
  test ++$i, $r->method eq "GET";
  #test ++$i, $r->method_number
  
  # args
  test ++$i, $r->args eq 'arg1=one&arg2=two';
  $r->args('foo=bar');
  test ++$i, $r->args eq 'foo=bar';
  $r->args(undef);
  test ++$i, not $r->args;
  test ++$i, not defined $r->args;
  
  $r->subprocess_env(SetKey => 'value');
  test ++$i, $r->subprocess_env('SetKey') eq 'value';
  my(%headers_in) = $r->headers_in;
  test ++$i, keys %headers_in;
  test ++$i, $r->header_in('UserAgent') || $r->header_in('User-Agent');
  $r->header_in('X-Hello' => "goodbye");
  test ++$i, $r->header_in("X-Hello") eq "goodbye";
  
  $r->header_out('X-Camel-Message' => "I can fly"); 
  test ++$i, $r->header_out("X-Camel-Message") eq "I can fly";
  my(%headers_out) = $r->headers_out;
  test ++$i, keys %headers_out;
  
  my(%err_headers_out) = $r->headers_out;
  test ++$i, keys %err_headers_out;
  #test ++$i, $r->err_header_out("Content-Type");
  $r->err_header_out('X-Die' => "uhoh"); 
  test ++$i, $r->err_header_out("X-Die") eq "uhoh";
  
  for (1..3)  {
      test ++$i, not $r->pnotes("NO_CHANCE");
      $r->pnotes(KEY => [qw(one two)]);
      my $val = $r->pnotes('KEY');
      test ++$i, $val && (ref($val) eq 'ARRAY');
      $val = $r->pnotes;
      test ++$i, $val && (ref($val) eq 'HASH');
      while(my($kk,$vv) = each %$val) {
  	test ++$i, $kk && $vv;
      }
  #    use Data::Dumper;
  #    print Dumper $val;
  }
  
  $r->notes("FOO", 1); 
  $r->notes("ANoteKey", "TRUE");
  test ++$i, $r->notes("ANoteKey");
  test ++$i, $r->content_type;
  test ++$i, $r->handler;
  
  $r->header_out(ByeBye => "TRUE");
  test ++$i, $r->header_out("ByeBye");
  $r->header_out(ByeBye => undef);
  test ++$i, not $r->header_out("ByeBye");
  
  #content_encoding
  test ++$i, $r->content_languages;
  #no_cache
  test ++$i, $r->uri;
  test ++$i, $r->filename;
  #test ++$i, $r->path_info;
  #test ++$i, $r->query_string;
  
  #just make sure we can actually call these
  test ++$i, $r->satisfies || 1;
  test ++$i, $r->some_auth_required || 1;
  
  $r->allowed(1 << M_GET);
  test ++$i, $r->allowed & (1 << M_GET);
  test ++$i, ! ($r->allowed & (1 << M_PUT));
  $r->allowed($r->allowed | (1 << M_PUT));
  test ++$i, $r->allowed & (1 << M_PUT);
  
  #dir_config
  
  my $c = $r->connection;
  test ++$i, $c;
  test ++$i, $c->remote_ip;
  test ++$i, $c->remote_addr;
  test ++$i, $c->local_addr;
  
  #Connection::remote_host
  #Connection::remote_logname
  #Connection::user
  #Connection::auth_type
  
  test ++$i, $r->server_root_relative;
  
  my $s = $r->server;
  test ++$i, $s;
  test ++$i, $s->server_admin;
  test ++$i, $s->server_hostname;
  test ++$i, $s->port;
  my $port = $s->port;
  for (32768, 65535) {
      $s->port($_);
      test ++$i, $s->port; # == $_;
  }
  $s->port($port);
  test ++$i, $s->port == $port;
  
  test ++$i, $s->timeout;
  
  for (my $srv = $r->server; $srv; $srv = $srv->next) {
      my $name = $srv->server_hostname;
  }
  
  ++$i;
  my $str = "ok $i\n";
  $r->print(\$str);
  
  test ++$i, $r->define("FOO") || 1; #just make sure we can call it
  for (qw(TEST NOCHANCE)) {
      if(Apache->define($_)) {
  	print "IfDefine $_\n";
      }
  }
  test ++$i, $r->module("Apache");
  test ++$i, not Apache->module("Not::A::Chance");
  test ++$i, Apache->module("Apache::Constants");
  test ++$i, not Apache->module("mod_nochance.c");
  test ++$i, Apache->module("mod_perl.c");
  
  #just make sure we can call this one
  if($test_custom_response) {
      test ++$i, $r->custom_response(403, "no chance") || 1;
      test ++$i, $r->custom_response(403) =~ /chance/;
      test ++$i, $r->custom_response(403, undef) || 1;
      test ++$i, not defined $r->custom_response(403);
  }
  
  if($test_get_set) {
      $r->set_handlers(PerlLogHandler => ['My::Logger']);
      my $handlers = $r->get_handlers('PerlLogHandler');
      test ++$i, @$handlers >= 1;
      $r->set_handlers(PerlLogHandler => undef);
      $handlers = $r->get_handlers('PerlLogHandler');
      test ++$i, @$handlers == 0;
      $handlers = $r->get_handlers('PerlHandler');
      test ++$i, @$handlers == 1;
      $r->set_handlers('PerlHandler', $handlers);
  
      $r->set_handlers(PerlTransHandler => DONE); #make sure a per-server config thing
works
      $handlers = $r->get_handlers('PerlTransHandler');
      test ++$i, @$handlers == 0;
  }
  
  if($test_dir_config) {
      require Data::Dumper;
      require Apache::ModuleConfig;
      my $dc = Apache::ModuleConfig->get($r);
      test ++$i, not $dc;
  
      {
  	package Apache::TestDirectives;
  	use Apache::test 'test';
  	my $scfg = Apache::ModuleConfig->get($r->server);
  	test ++$i, $scfg;
  	test ++$i,  __PACKAGE__->isa($scfg->{ServerClass});
  	print Data::Dumper::Dumper($scfg);
      }
      for my $cv (
  		sub {
  		    package Apache::TestDirectives;
  		    Apache::ModuleConfig->get(Apache->request);
  		},
                  sub {
  		    Apache::ModuleConfig->get($r, "Apache::TestDirectives");
  		})
      {
          my $cfg = $cv->();
          $r->print(Data::Dumper::Dumper($cfg));
          test ++$i, "$cfg" =~ /HASH/;
          test ++$i, keys(%$cfg) >= 3;
          test ++$i, $cfg->{FromNew};
          unless ($cfg->{SetFromScript}) {
  	    $cfg->{SetFromScript} = [$0,$$];
  	}
      }
  }
  
  @My::Req::ISA = qw(Apache);
  
  my $hr = bless {
      _r => $r,
  }, "My::Req";
  
  test ++$i, $hr->filename;
  delete $hr->{_r};
  my $uri;
  
  eval { 
      $uri = $hr->uri;
  };
  test ++$i, not $uri;
  print $@ if $@;
  
  use Apache::test qw($USE_THREAD);
  if ($USE_THREAD) {
      #under Solaris at least, according to Brian P Millett <bpm@ec-group.com>
      warn "XXX: need to fix \$r->exit in t/net/api w/ threads\n";
  }
  else {
      $r->exit unless $is_xs;
  }
  
  
  
  
  
  
  
  1.1                  httpd-apreq/t/book.gif
  
  	<<Binary file>>
  
  
  1.1                  httpd-apreq/t/cookie.t
  
  Index: cookie.t
  ===================================================================
  use strict;
  use Apache::test qw(skip_test have_httpd test have_module);
  use Apache::src ();
  #use lib qw(lib blib/lib blib/arch);
  eval 'require Apache::Cookie' or die $@;
  #warn "No CGI::Cookie" and skip_test unless have_module "CGI::Cookie";
  #warn "$@:No Apache::Cookie" and skip_test unless have_module "Apache::Cookie";
  
  #unless (Apache::src->mmn_eq) {
  #    skip_test if not $Is_dougm;
  #}
  
  my $ua = LWP::UserAgent->new;
  my $cookie = "one=bar-one&a; two=bar-two&b; three=bar-three&c";
  my $url = "http://localhost:$ENV{PORT}/request-cookie.pl";
  my $request = HTTP::Request->new('GET', $url);
  $request->header(Cookie => $cookie);
  my $response = $ua->request($request, undef, undef); 
  print $response->content;
   
  
  
  
  1.1                  httpd-apreq/t/request-cookie.pl
  
  Index: request-cookie.pl
  ===================================================================
  #!perl
  use strict;
  use CGI;
  use Apache::test;
  
  eval {
    require Apache::Request;
    require Apache::Cookie;
    require CGI::Cookie;
  };
  
  my $r = Apache->request;
  $r->send_http_header('text/plain');
  
  unless (have_module "Apache::Cookie" and Apache::Request->can('upload')) {
      print "1..0\n";
      print $@ if $@;
      print "$INC{'Apache/Request.pm'}\n";
      return;
  }
  
  my $i = 0;
  my $tests = 33;
  $tests += 7 if $r->headers_in->get("Cookie");
  
  print "1..$tests\n";
  
  my $letter = 'a';
  for my $name (qw(one two three)) { 
      my $c = Apache::Cookie->new($r,
  				-name    =>  $name,  
  				-value  =>  ["bar_$name", $letter],  
  				-expires =>  '+3M',  
  				-path    =>  '/'  
  				);  
      my $cc = CGI::Cookie->new(
  			      -name    =>  $name,  
  			      -value  =>  ["bar_$name", $letter],  
  			      -expires =>  '+3M',  
  			      -path    =>  '/'  
  			      );
      ++$letter;
      $c->bake;
  
      my $cgi_as_string = $cc->as_string;
      my $as_string = $c->as_string;
      my $header_out = ($r->err_headers_out->get("Set-Cookie"))[-1];
      my @val = $c->value;
      print "VALUE: @val\n";
      for my $v ("string", [@val]) {
  	$c->value($v);
  	my @arr = $c->value;
  	my $n = @arr;
  	if (ref $v) {
  	    test ++$i, $n == 2;
  	}
  	else {
  	    test ++$i, $n == 1;
  	}
  	print "  VALUE: @arr ($n)\n";
  	$c->value(\@val); #reset
      }
  
      for (1,0) {
  	my $secure = $c->secure;
  	$c->secure($_);
  	print "secure: $secure\n";
      }
  
      print "as_string:  `$as_string'\n";
      print "header_out: `$header_out'\n";
      print "cgi cookie: `$cgi_as_string\n";  
      test ++$i, cookie_eq($as_string, $header_out);
      test ++$i, cookie_eq($as_string, $cgi_as_string);
  } 
  
  my (@Hargs) = (
  	       "-name" => "key", 
  	       "-values" => {qw(val two)},  
  	       "-domain" => ".cp.net",
  	      );
  my (@Aargs) = (
  	       "-name" => "key", 
  	       "-values" => [qw(val two)],  
  	       "-domain" => ".cp.net",
  	      );
  my (@Sargs) = (
  	       "-name" => "key", 
  	       "-values" => 'one',  
  	       "-domain" => ".cp.net",
  	      );
  
  my $done_meth = 0;
  for my $rv (\@Hargs, \@Aargs, \@Sargs) {
      my $c1 = Apache::Cookie->new($r, @$rv);
      my $c2 = CGI::Cookie->new(@$rv);
  
      for ($c1, $c2) {
  	$_->expires("+3h");
      }
  
      for my $meth (qw(as_string name domain path expires secure)) {
  	my $one = $c1->$meth() || "";
  	my $two = $c2->$meth() || "";
  	print "Apache::Cookie: $meth => $one\n";
  	print "CGI::Cookie:    $meth => $two\n";
  	test ++$i, cookie_eq($one, $two);
      } 
  }
  
  if(my $string = $r->headers_in->get('Cookie')) { 
      print $string, $/; 
      my %done = ();
  
      print "SCALAR context (as_string method):\n";
  
      print " Apache::Cookie:\n";
      my $hv = Apache::Cookie->new($r)->parse($string);
      for (sort keys %$hv) {
  	print "   $_ => ", $hv->{$_}->as_string, $/;
  	$done{$_} = $hv->{$_}->as_string;
      }
  
      print " CGI::Cookie:\n";
      $hv = CGI::Cookie->parse($string);
      for (sort keys %$hv) {
  	print "   $_ => ", $hv->{$_}->as_string, $/;
  	test ++$i, cookie_eq($done{$_}, $hv->{$_}->as_string);
      }
  
      %done = ();
  
      print "ARRAY context (value method):\n";
      print " Apache::Cookie:\n";
      my %hv = Apache::Cookie->new($r)->parse($string);
      my %fetch = Apache::Cookie->fetch;
      test ++$i, keys %hv == keys %fetch;
  
      for (sort keys %hv) {
  	$done{$_} = join ", ", $hv{$_}->value;
  	print "   $_ => $done{$_}\n";
      }
      print " CGI::Cookie:\n";
      %hv = CGI::Cookie->parse($string);
      for (sort keys %hv) {
  	my $val = join ", ", $hv{$_}->value;
  	test ++$i, cookie_eq($done{$_}, $val);
  	print "   $_ => $val\n";
      }
  } 
  else { 
      print "NO Cookie set"; 
  } 
  
  {
      my $cgi_exp = CGI::expires('-1d', 'cookie');
      my $cookie_exp = Apache::Cookie->expires('-1d');
      print "cookie: $cookie_exp\ncgi: $cgi_exp\n";
      test ++$i, cookie_eq($cookie_exp, $cgi_exp);
  }
  {
      my $cgi_exp = CGI::expires('-1d', 'http');
      my $apr_exp = Apache::Request->expires('-1d');
      print "apr: $apr_exp\ncgi: $cgi_exp\n";
      test ++$i, cookie_eq($apr_exp, $cgi_exp);
  }
  
  test ++$i, 1;
  
  sub cookie_eq {
      my($one, $two) = @_;
      unless ($one eq $two) {
  	print STDERR "cookie mismatch:\n", 
  	"`$one'\n", "   vs.\n", "`$two'\n";
      }
      ($one && $two) || (!$one && !$two);
  }
  
  
  
  1.1                  httpd-apreq/t/request-param.pl
  
  Index: request-param.pl
  ===================================================================
  #!perl
  use strict;
  use Apache::test;
  
  my $r = Apache->request;
  $r->send_http_header('text/plain');
  
  eval {
      require Apache::Request;
  };
  
  unless (have_module "Apache::Request" and Apache::Request->can('upload')) {
      print "1..0\n";
      print $@ if $@;
      print "$INC{'Apache/Request.pm'}\n";
      return;
  }
  
  my $apr = Apache::Request->new($r);
  
  for ($apr->param) {
      my(@v) = $apr->param($_);
      print "param $_ => ", join ",", @v;
      print $/;
  }
  
  
  
  
  1.1                  httpd-apreq/t/request-upload.pl
  
  Index: request-upload.pl
  ===================================================================
  #!perl
  use strict;
  use Apache::test;
  
  my $r = Apache->request;
  $r->send_http_header('text/plain');
  
  eval {
      require Apache::Request;
  };
  
  unless (have_module "Apache::Request" and Apache::Request->can('upload')) {
      print "1..0\n";
      print $@ if $@;
      print "$INC{'Apache/Request.pm'}\n";
      return;
  }
  
  my $apr = Apache::Request->new($r);
  
  for ($apr->param) {
      my(@v) = $apr->param($_);
      print "param $_ => @v\n";
  }
  
  for (my $upload = $apr->upload; $upload; $upload = $upload->next) {
      my $fh = $upload->fh;
      my $filename = $upload->filename;
      my $name = $upload->name;
      my $type = $upload->type;
      next unless $filename;
  
      print "$name $filename ($type)";
      if ($fh and $name) {
  	no strict;
  	if (my $no = fileno($filename)) {
  	    print " fileno => $no";
  	}
      }
      print "\n";
      close $fh;
  }
  
  my $first = $apr->upload->name;
  my $first_filename = $apr->upload->filename;
  my $first_fh = $apr->upload->fh;
  if ($first_fh) {
      while (<$first_fh>) { }
  }
  close $first_fh;
  
  for my $upload ($apr->upload) {
      my $fh = $upload->fh;
      my $filename = $upload->filename;
      my $name = $upload->name;
      next unless $filename;
  
      my($lines, $bytes);
      $lines = $bytes = 0;
  
      {
  	no strict;
  	if (fileno($filename)) {
  	    $fh = *$filename{IO};
  	    print "COMPAT: $fh\n";
  	} 
      }
      use File::Basename;
      local *OUT;
      if (my $dir = $apr->header_in("X-Upload-Tmp")) {
  	if (-d $dir) {
  	    Apache->untaint($dir);
  	    my $file = basename $filename;
  	    open OUT, ">$dir/$file" or die $!;
  	}
      }
      while(<$fh>) {
  	++$lines;
  	$bytes += length;
  	print OUT $_ if fileno OUT;
      }
      close OUT if fileno OUT;
      close $fh;
  
      my $info = $upload->info;
      while (my($k,$v) = each %$info) {
  	print "INFO: $k => $v\n";
      }
      unless ($name eq $first) {
  	print "-" x 40, $/;
  	my $info = $apr->upload($first)->info;
  	print "Lookup `$first':[$info]\n";
  	while (my($k,$v) = each %$info) {
  	    print "INFO: $k => $v\n";
  	}
  	my $type = $apr->upload($first)->info("content-type");
  	unless ($type) {
  	    die "upload->info is broken";
  	} 
  	print "TYPE: $type\n";
  	print "-" x 40, $/;
      }
      my $wanted = $upload->size;
      unless ($bytes == $wanted) {
  	die "wanted $wanted bytes, got $bytes bytes";
      }
      print "Server: Lines: $lines\n";
      print "$filename bytes=$bytes,wanted=$wanted\n";
  }
  
  
  
  
  1.1                  httpd-apreq/t/request.t
  
  Index: request.t
  ===================================================================
  use strict;
  use Apache::test;
  use Apache::src ();
  use Cwd qw(fastcwd);
  
  require HTTP::Request::Common; 
  require CGI;
  
  $HTTP::Request::Common::VERSION ||= '1.00'; #-w 
  unless ($CGI::VERSION >= 2.39 and  
  	$HTTP::Request::Common::VERSION >= 1.08) {
      print "CGI.pm: $CGI::VERSION\n";
      print "HTTP::Request::Common: $HTTP::Request::Common::VERSION\n";
      skip_test;
  } 
  
  my $PWD = fastcwd;
  my @binary = "$PWD/book.gif";
  
  my $test_pods = 3;
  my $tests = 2;
  
  unless ($USE_SFIO) {
      $tests += ($test_pods * 2) + (@binary * 2);
  }
  
  print "1..$tests\n";
  my $i = 0;
  my $ua = LWP::UserAgent->new;
  
  use DirHandle ();
  
  for my $cv (\&post_test, \&get_test) {
      $cv->();
  }
  
  
  upload_test($_) for qw(perlfunc.pod perlpod.pod perlxs.pod), @binary;
  
  
  sub post_test {
      my $enc = 'application/x-www-form-urlencoded';
      param_test(sub {
  	my($url, $data) = @_;
          HTTP::Request::Common::POST($url, 
  				    Content_Type => $enc,
  				    Content      => $data,
  				    );
      });
  }
  
  sub get_test {
      my $enc = 'application/x-www-form-urlencoded';
  
      param_test(sub {
  	my($url, $data) = @_;
          HTTP::Request::Common::GET("$url?$data");
      });
  }
  
  sub param_test {
      my $cv = shift;
      my $url = "http://localhost:$ENV{PORT}/request-param.pl";
      my $data = 
  	"ONE=ONE_value&TWO=TWO_value&" .
  	"THREE=M1&THREE=M2&THREE=M3";
  		
      my $response = $ua->request($cv->($url, $data));
  
      my $page = $response->content;
      print $response->as_string unless $response->is_success;
      my $expect = <<EOF;
  param ONE => ONE_value
  param TWO => TWO_value
  param THREE => M1,M2,M3
  EOF
      my $ok = $page eq $expect;
      test ++$i, $ok;
      print $response->as_string unless $ok;
  }
  
  sub upload_test {
      my $podfile = shift || "func";
      my $url = "http://localhost:$ENV{PORT}/request-upload.pl";
      my $file = "";
      if (-e $podfile) {
  	$file = $podfile;
      }
      else {
  	for my $path (@INC) {
  	    last if -e ($file = "$path/pod/$podfile");
  	}
      }
  
      $file = $0 unless -e $file;
      my $lines = 0;
      local *FH;
      open FH, $file or die "open $file $!";
      binmode FH; #for win32
      ++$lines while defined <FH>;
      close FH;
      my(@headers);
      my $response = $ua->request(HTTP::Request::Common::POST($url,
                     @headers,
  		   Content_Type => 'multipart/form-data',
  		   Content      => [count => 'count lines',
  				    filename  => [$file],
  				    ]));
  
      my $page = $response->content;
      print $response->as_string unless $response->is_success;
      test ++$i, ($page =~ m/Lines:\s+(\d+)/m);
      print "$file should have $lines lines (request-upload.pl says: $1)\n"
  	unless $1 == $lines;
      test ++$i, $1 == $lines;
  }
  
  
  

Mime
View raw message