view release on metacpan or  search on metacpan

t/test.pl  view on Meta::CPAN

}

if (!defined $pid) {
  die "Cannot fork: $!";
} elsif ($pid == 0) {
  say "This is the Phoebe server listening on port $port...";
  use Config;
  my $secure_perl_path = $Config{perlpath};
  my @args = ("blib/script/phoebe",
	      # The test files containing hostnames are UTF-8 encoded, thus
	      # $host and @host are unicode strings. Command line parsing
	      # expects them encoded in the current locale, however.
	      (map { "--host=" . encode(locale => $_) } @hosts),
	      "--port=$port",
	      "--log_level=warn", # set to debug if you are bug hunting?
	      "--cert_file=t/cert.pem",
	      "--key_file=t/key.pem",
	      "--wiki_dir=$dir",
	      "--wiki_mime_type=image/jpeg",
	      (map { "--wiki_page=" . encode(locale => $_) } @pages),
	      (map { "--wiki_space=" . encode(locale => $_) } @spaces));
  exec($secure_perl_path, @args) or die "Cannot exec: $!";
}

sub query_gemini {
  my $query = shift;
  my $text = shift;
  my $cert = shift // 1; # suppress use of client certificate in the test
  my $cert_file = [undef, "t/cert.pem", "t/cert2.pem"]->[$cert];
  my $key_file = [undef, "t/key.pem", "t/key2.pem"]->[$cert];
  my ($header, $mimetype, $encoding, $buffer);
  # create client
  Mojo::IOLoop->client(
    {
      address => "localhost",
      port => $port,
      tls => 1,
      tls_cert => $cert_file,
      tls_key => $key_file,
      tls_options => { SSL_verify_mode => 0x00 },
    } => sub {
      my ($loop, $err, $stream) = @_;
      die "Client creation failed: $err\n" if $err;
      $stream->timeout(2);
      $stream->on(error => sub {
	my ($stream, $err) = @_;
	die "Stream error: $err\n" if $err });
      $stream->on(close => sub {
	my ($stream) = @_;
	diag "Closing stream\n" if $ENV{TEST_VERBOSE} });
      $stream->on(read => sub {
	my ($stream, $bytes) = @_;
	diag "Reading " . length($bytes) . " bytes\n" if $ENV{TEST_VERBOSE};
	if ($header and $encoding) {
	  $buffer .= decode($encoding, $bytes);
	} elsif ($header) {
	  $buffer .= $bytes;
	} else {
	  ($header) = $bytes =~ /^(.*?)\r\n/;
	  $header = decode_utf8 $header;
	  if ($header =~ /^2\d* (?:text\/\S+)?(?:; *charset=(\S+))?$/g) {
	    # empty, or text without charset defaults to UTF-8
	    $encoding = $1 || 'UTF-8';
	  }
	  $bytes =~ s/^(.*?)\r\n//;
	  if ($encoding) {
	    $buffer .= decode($encoding, $bytes);
	  } else {
	    $buffer .= $bytes;
	  }
	}});
      # Write request
      $stream->write($query);
      $stream->write("\r\n") unless $query =~ /^POST/; # GET and Gemini requests end in \r\n
      $stream->write($text) if $text });
  # Start event loop if necessary
  Mojo::IOLoop->start unless Mojo::IOLoop->is_running;

  # When we're done
  return "" unless $header;
  return "$header\r\n$buffer";
}

sub query_web {
  my $query = shift;
  my $cert = shift // 1; # suppress use of client certificate in the test
  $query .= "\r\n" unless $query =~ /^POST/; # add empty line for GET requests
  my $response = query_gemini($query, undef, $cert);
  # fixup encoding for two trivial cases of encoding html
  my $header_end = index($response, "\r\n\r\n");
  if (substr($response, 0, $header_end + 2) =~ /content-type: text\/[a-z]+; charset=(\S+)/i
      or substr($response, $header_end + 4) =~ /<meta charset=\"(\S+)\">/i) {
    my $encoding = $1;
    $response = substr($response, 0, $header_end + 4)
	. decode($encoding, substr($response, $header_end + 4));
  }
  return $response;
}

my $total = 0;
my $ok = 0;

# What I'm seeing is that $@ is the empty string and $! is "Connection refused"
# even though I thought $@ would be set. Oh well.
say "This is the Phoebe client waiting for the server to start on port $port...";
# In order to avoid "skipped: Giving up after 5s" by CPAN tester gregor herrmann,
# make sure to wait more than that!
for (qw(1 1 1 1 1 2 3 5)) {
  if (not $total or $!) {
    $total += $_;
    sleep $_;
    eval { query_gemini("gemini://$host:$port/") };
  } else {
    $ok = 1;
    last;
  }
}

plan skip_all => "Giving up after ${total}s\n" unless $ok;

# We cannot test $example up above; we must run this test once we established
# that the plan is not to skil all. If we don't wait, we'll get the following
# error: "Parse errors: Bad plan. You planned 0 tests but ran 1."
like($example, qr/^# tested by $0\n/, "Example found") if $ok and $example;

1;