;
sub debug($) {
my $message = $_[0];
$message =~ s!\n!\n#SERVER:!g;
warn "#SERVER: $message"
if $ENV{TEST_HTTP_VERBOSE};
};
SERVERLOOP: {
my $quitserver;
while (my $c = $d->accept) {
debug "New connection";
while (my $r = $c->get_request) {
debug "Request:\n" . $r->as_string;
my $location = ($r->uri->path || "/");
my ($link1,$link2) = ('','');
if ($location =~ m!^/link/([^/]+)/(.*)$!) {
($link1,$link2) = ($1,$2);
};
my $res;
if ($location eq '/get_server_log') {
$res = HTTP::Response->new(200, "OK", undef, $log);
undef $log;
} elsif ( $location eq '/quit_server') {
debug "Quitting";
$res = HTTP::Response->new(200, "OK", undef, "quit");
$c->force_last_request;
$quitserver = 1;
#close LOG;
} else {
$log .= "Request:\n" . $r->as_string . "\n";
if ($location =~ m!^/redirect/(.*)$!) {
$res = HTTP::Response->new(302);
$res->header('location', $d->url . $1);
} elsif ($location =~ m!^/notfound/(.*)$!) {
$res = HTTP::Response->new(404);
#$res->header('location', $d->url . $1);
} else {
my $q = CGI->new($r->uri->query);
# Make sticky form fields
my ($query,$session,%cat);
$query = defined $q->param('query') ? $q->param('query') : "(empty)";
$session = defined $q->param('session') ? $q->param('session') : 1;
%cat = map { $_ => 1 } (defined $q->param('cat') ? $q->param('cat') : qw( cat_foo cat_bar ));
my @categories = map { $cat{$_} ? "checked" : "" } qw( cat_foo cat_bar cat_baz );
$res = HTTP::Response->new(200, "OK", undef, sprintf($body,$location,$session,$query,@categories));
$res->content_type('text/html');
debug "Request " . ($r->uri->path || "/");
};
};
debug "Response:\n" . $res->as_string;
$c->send_response($res);
last if $quitserver;
}
$c->close;
undef($c);
last SERVERLOOP
if $quitserver;
}
};
END { debug "Server stopped" };
__DATA__
WWW::Mechanize::Shell test page
Location: %s
Link /test
Link /foo
Link /
/Link
/Link in slashes/
Link foo1.save_log_server_test.tmp
Link foo2.save_log_server_test.tmp
Link foo3.save_log_server_test.tmp
| Col1 | Col2 | Col3 |
|---|
| A1 | A2 | A3 |
| B1 | B2 | B3 |
| C1 | C2 | C3 |
HTML-Display-0.40/inc/IO/ 0000755 0001750 0001750 00000000000 12162617154 014235 5 ustar corion corion HTML-Display-0.40/inc/IO/Catch.pm 0000755 0001750 0001750 00000002416 12162616301 015614 0 ustar corion corion package IO::Catch;
use strict;
use Carp qw(croak);
=head1 NAME
IO::Catch - capture STDOUT and STDERR into global variables
=head1 AUTHOR
Max Maischein ( corion at cpan.org )
All code ripped from pod2test by M. Schwern
=head1 SYNOPSIS
# pre-5.8.0's warns aren't caught by a tied STDERR.
use vars qw($_STDOUT_, $_STDERR_);
tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!;
tie *STDERR, 'IO::Catch', '_STDERR_' or die $!;
# now you can access $main::_STDOUT_ and $_STDERR_
# to see the output.
=cut
use vars qw($VERSION);
$VERSION = '0.02';
sub TIEHANDLE {
my($class, $var) = @_;
croak "Need a variable name to tie to" unless $var;
return bless { var => $var }, $class;
}
sub PRINT {
no strict 'refs';
my($self) = shift;
${'main::'.$self->{var}} = ""
unless defined ${'main::'.$self->{var}};
${'main::'.$self->{var}} .= join '', @_;
}
sub PRINTF {
no strict 'refs';
my($self) = shift;
my $tmpl = shift;
${'main::'.$self->{var}} = ""
unless defined ${'main::'.$self->{var}};
${'main::'.$self->{var}} .= sprintf $tmpl, @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
sub BINMODE {}
1;
HTML-Display-0.40/Makefile.PL 0000755 0001750 0001750 00000001367 12162616301 015132 0 ustar corion corion use ExtUtils::MakeMaker;
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
WriteMakefile(
'NAME' => 'HTML::Display',
'VERSION_FROM' => 'lib/HTML/Display.pm', # finds $VERSION
'PREREQ_PM' => {
'parent' => 0.218,
'URI::URL' => 0.00,
'Test::Harness' => 2.30,
'LWP' => 5.69,
'HTML::TokeParser::Simple' => 2,
}, # e.g., Module::Name => 1.1
($] >= 5.005 ? ## Add these new keywords supported since 5.005
(ABSTRACT_FROM => 'lib/HTML/Display.pm', # retrieve abstract from module
AUTHOR => 'Max Maischein ') : ()),
);
# To make Test::Prereq happy
1;
HTML-Display-0.40/META.yml 0000644 0001750 0001750 00000001074 12162617154 014430 0 ustar corion corion ---
abstract: 'display HTML locally in a browser'
author:
- 'Max Maischein '
build_requires:
ExtUtils::MakeMaker: 0
configure_requires:
ExtUtils::MakeMaker: 0
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.130880'
license: unknown
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: HTML-Display
no_index:
directory:
- t
- inc
requires:
HTML::TokeParser::Simple: 2
LWP: 5.69
Test::Harness: 2.3
URI::URL: 0
parent: 0.218
version: 0.40
HTML-Display-0.40/META.json 0000644 0001750 0001750 00000001776 12162617154 014611 0 ustar corion corion {
"abstract" : "display HTML locally in a browser",
"author" : [
"Max Maischein "
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.130880",
"license" : [
"unknown"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : "2"
},
"name" : "HTML-Display",
"no_index" : {
"directory" : [
"t",
"inc"
]
},
"prereqs" : {
"build" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"requires" : {
"HTML::TokeParser::Simple" : "2",
"LWP" : "5.69",
"Test::Harness" : "2.3",
"URI::URL" : "0",
"parent" : "0.218"
}
}
},
"release_status" : "stable",
"version" : "0.40"
}
HTML-Display-0.40/t/ 0000755 0001750 0001750 00000000000 12162617154 013420 5 ustar corion corion HTML-Display-0.40/t/embedded-HTML-Display-OSX-Camino.t 0000755 0001750 0001750 00000002434 12162616301 021355 0 ustar corion corion #!/opt/perl58/bin/perl -w
use Test::More 'no_plan';
package Catch;
sub TIEHANDLE {
my($class, $var) = @_;
return bless { var => $var }, $class;
}
sub PRINT {
my($self) = shift;
${'main::'.$self->{var}} .= join '', @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
sub BINMODE {}
my $Original_File = 'lib/HTML/Display/OSX/Camino.pm';
package main;
# pre-5.8.0's warns aren't caught by a tied STDERR.
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
tie *STDERR, 'Catch', '_STDERR_' or die $!;
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 13 lib/HTML/Display/OSX/Camino.pm
my $browser = HTML::Display->new(
class => 'HTML::Display::Dump',
);
$browser->display("Hello world!
");
;
}
};
is($@, '', "example from line 13");
};
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
};
HTML-Display-0.40/t/embedded-HTML-Display-Phoenix.t 0000755 0001750 0001750 00000002357 12162616301 021116 0 ustar corion corion #!/opt/perl58/bin/perl -w
use Test::More 'no_plan';
package Catch;
sub TIEHANDLE {
my($class, $var) = @_;
return bless { var => $var }, $class;
}
sub PRINT {
my($self) = shift;
${'main::'.$self->{var}} .= join '', @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
sub BINMODE {}
my $Original_File = 'lib/HTML/Display/Phoenix.pm';
package main;
# pre-5.8.0's warns aren't caught by a tied STDERR.
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
tie *STDERR, 'Catch', '_STDERR_' or die $!;
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 13 lib/HTML/Display/Phoenix.pm
my $browser = HTML::Display->new();
$browser->display("Hello world!
");
;
}
};
is($@, '', "example from line 13");
};
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
};
HTML-Display-0.40/t/embedded-HTML-Display-Win32.t 0000755 0001750 0001750 00000002353 12162616301 020402 0 ustar corion corion #!/opt/perl58/bin/perl -w
use Test::More 'no_plan';
package Catch;
sub TIEHANDLE {
my($class, $var) = @_;
return bless { var => $var }, $class;
}
sub PRINT {
my($self) = shift;
${'main::'.$self->{var}} .= join '', @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
sub BINMODE {}
my $Original_File = 'lib/HTML/Display/Win32.pm';
package main;
# pre-5.8.0's warns aren't caught by a tied STDERR.
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
tie *STDERR, 'Catch', '_STDERR_' or die $!;
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 12 lib/HTML/Display/Win32.pm
my $browser = HTML::Display->new();
$browser->display("Hello world!
");
;
}
};
is($@, '', "example from line 12");
};
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
};
HTML-Display-0.40/t/embedded-HTML-Display-Mozilla.t 0000755 0001750 0001750 00000002357 12162616301 021113 0 ustar corion corion #!/opt/perl58/bin/perl -w
use Test::More 'no_plan';
package Catch;
sub TIEHANDLE {
my($class, $var) = @_;
return bless { var => $var }, $class;
}
sub PRINT {
my($self) = shift;
${'main::'.$self->{var}} .= join '', @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
sub BINMODE {}
my $Original_File = 'lib/HTML/Display/Mozilla.pm';
package main;
# pre-5.8.0's warns aren't caught by a tied STDERR.
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
tie *STDERR, 'Catch', '_STDERR_' or die $!;
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 13 lib/HTML/Display/Mozilla.pm
my $browser = HTML::Display->new();
$browser->display("Hello world!
");
;
}
};
is($@, '', "example from line 13");
};
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
};
HTML-Display-0.40/t/embedded-HTML-Display-Common.t 0000755 0001750 0001750 00000014640 12162616301 020732 0 ustar corion corion #!/opt/perl58/bin/perl -w
use Test::More 'no_plan';
package Catch;
sub TIEHANDLE {
my($class, $var) = @_;
return bless { var => $var }, $class;
}
sub PRINT {
my($self) = shift;
${'main::'.$self->{var}} .= join '', @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
sub BINMODE {}
my $Original_File = 'lib/HTML/Display/Common.pm';
package main;
# pre-5.8.0's warns aren't caught by a tied STDERR.
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
tie *STDERR, 'Catch', '_STDERR_' or die $!;
SKIP: {
# A header testing whether we find all prerequisites :
# Check for module parent
eval { require parent };
skip "Need module parent to run this test", 1
if $@;
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 22 lib/HTML/Display/Common.pm
no warnings 'redefine';
*HTML::Display::WhizBang::display_html = sub {};
package HTML::Display::WhizBang;
use parent 'HTML::Display::Common';
sub new {
my ($class) = shift;
my %args = @_;
my $self = $class->SUPER::new(%args);
# do stuff
$self;
};
;
}
};
is($@, '', "example from line 22");
};
SKIP: {
# A header testing whether we find all prerequisites :
# Check for module HTML::Display
eval { require HTML::Display };
skip "Need module HTML::Display to run this test", 1
if $@;
# Check for module parent
eval { require parent };
skip "Need module parent to run this test", 1
if $@;
# The original POD test
{
undef $main::_STDOUT_;
undef $main::_STDERR_;
#line 22 lib/HTML/Display/Common.pm
no warnings 'redefine';
*HTML::Display::WhizBang::display_html = sub {};
package HTML::Display::WhizBang;
use parent 'HTML::Display::Common';
sub new {
my ($class) = shift;
my %args = @_;
my $self = $class->SUPER::new(%args);
# do stuff
$self;
};
package main;
use HTML::Display;
my $browser = HTML::Display->new( class => "HTML::Display::WhizBang");
isa_ok($browser,"HTML::Display::Common");
undef $main::_STDOUT_;
undef $main::_STDERR_;
}
};
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
};
SKIP: {
# A header testing whether we find all prerequisites :
# Check for module HTML::Display::Dump
eval { require HTML::Display::Dump };
skip "Need module HTML::Display::Dump to run this test", 1
if $@;
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 72 lib/HTML/Display/Common.pm
no warnings 'redefine';
*HTML::Display::new = sub {
my $class = shift;
require HTML::Display::Dump;
return HTML::Display::Dump->new(@_);
};
my $html = "Hello world!
";
my $browser = HTML::Display->new();
$browser->display( html => $html );
;
}
};
is($@, '', "example from line 72");
};
SKIP: {
# A header testing whether we find all prerequisites :
# Check for module HTML::Display::Dump
eval { require HTML::Display::Dump };
skip "Need module HTML::Display::Dump to run this test", 1
if $@;
# The original POD test
{
undef $main::_STDOUT_;
undef $main::_STDERR_;
#line 72 lib/HTML/Display/Common.pm
no warnings 'redefine';
*HTML::Display::new = sub {
my $class = shift;
require HTML::Display::Dump;
return HTML::Display::Dump->new(@_);
};
my $html = "Hello world!
";
my $browser = HTML::Display->new();
$browser->display( html => $html );
isa_ok($browser, "HTML::Display::Dump","The browser");
is( $main::_STDOUT_,"Hello world!
","HTML gets output");
undef $main::_STDOUT_;
undef $main::_STDERR_;
}
};
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
};
SKIP: {
# A header testing whether we find all prerequisites :
# Check for module HTML::Display::Dump
eval { require HTML::Display::Dump };
skip "Need module HTML::Display::Dump to run this test", 1
if $@;
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 97 lib/HTML/Display/Common.pm
no warnings 'redefine';
*HTML::Display::new = sub {
my $class = shift;
require HTML::Display::Dump;
return HTML::Display::Dump->new(@_);
};
my $html = '
';
my $browser = HTML::Display->new();
# This will display part of the Google logo
$browser->display( html => $html, base => 'http://www.google.com' );
;
}
};
is($@, '', "example from line 97");
};
SKIP: {
# A header testing whether we find all prerequisites :
# Check for module HTML::Display::Dump
eval { require HTML::Display::Dump };
skip "Need module HTML::Display::Dump to run this test", 1
if $@;
# The original POD test
{
undef $main::_STDOUT_;
undef $main::_STDERR_;
#line 97 lib/HTML/Display/Common.pm
no warnings 'redefine';
*HTML::Display::new = sub {
my $class = shift;
require HTML::Display::Dump;
return HTML::Display::Dump->new(@_);
};
my $html = '';
my $browser = HTML::Display->new();
# This will display part of the Google logo
$browser->display( html => $html, base => 'http://www.google.com' );
isa_ok($browser, "HTML::Display::Dump","The browser");
is( $main::_STDOUT_,
'',
"HTML gets output");
$main::_STDOUT_ = "";
$browser->display( html => $html, location => 'http://www.google.com' );
is( $main::_STDOUT_,
'',
"HTML gets output");
undef $main::_STDOUT_;
undef $main::_STDERR_;
}
};
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
};
HTML-Display-0.40/t/embedded-HTML-Display-OSX.t 0000755 0001750 0001750 00000002347 12162616301 020154 0 ustar corion corion #!/opt/perl58/bin/perl -w
use Test::More 'no_plan';
package Catch;
sub TIEHANDLE {
my($class, $var) = @_;
return bless { var => $var }, $class;
}
sub PRINT {
my($self) = shift;
${'main::'.$self->{var}} .= join '', @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
sub BINMODE {}
my $Original_File = 'lib/HTML/Display/OSX.pm';
package main;
# pre-5.8.0's warns aren't caught by a tied STDERR.
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
tie *STDERR, 'Catch', '_STDERR_' or die $!;
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 13 lib/HTML/Display/OSX.pm
my $browser = HTML::Display->new();
$browser->display("Hello world!
");
;
}
};
is($@, '', "example from line 13");
};
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
};
HTML-Display-0.40/t/embedded-HTML-Display-Opera.t 0000755 0001750 0001750 00000002353 12162616301 020546 0 ustar corion corion #!/opt/perl58/bin/perl -w
use Test::More 'no_plan';
package Catch;
sub TIEHANDLE {
my($class, $var) = @_;
return bless { var => $var }, $class;
}
sub PRINT {
my($self) = shift;
${'main::'.$self->{var}} .= join '', @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
sub BINMODE {}
my $Original_File = 'lib/HTML/Display/Opera.pm';
package main;
# pre-5.8.0's warns aren't caught by a tied STDERR.
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
tie *STDERR, 'Catch', '_STDERR_' or die $!;
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 13 lib/HTML/Display/Opera.pm
my $browser = HTML::Display->new();
$browser->display("Hello world!
");
;
}
};
is($@, '', "example from line 13");
};
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
};
HTML-Display-0.40/t/embedded-HTML-Display-TempFile.t 0000755 0001750 0001750 00000002660 12162616301 021206 0 ustar corion corion #!/opt/perl58/bin/perl -w
use Test::More 'no_plan';
package Catch;
sub TIEHANDLE {
my($class, $var) = @_;
return bless { var => $var }, $class;
}
sub PRINT {
my($self) = shift;
${'main::'.$self->{var}} .= join '', @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
sub BINMODE {}
my $Original_File = 'lib/HTML/Display/TempFile.pm';
package main;
# pre-5.8.0's warns aren't caught by a tied STDERR.
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
tie *STDERR, 'Catch', '_STDERR_' or die $!;
SKIP: {
# A header testing whether we find all prerequisites :
# Check for module base
eval { require base };
skip "Need module base to run this test", 1
if $@;
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 13 lib/HTML/Display/TempFile.pm
package HTML::Display::External;
use parent 'HTML::Display::TempFile';
sub browsercmd {
# Return the string to pass to system()
# %s will be replaced by the temp file name
};
;
}
};
is($@, '', "example from line 13");
};
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
};
HTML-Display-0.40/t/01-HTML-Display-TempFile-share.t 0000755 0001750 0001750 00000001206 12162616301 020770 0 ustar corion corion use strict;
use Test::More tests => 2;
use lib 'inc';
use IO::Catch;
use vars qw( $display $captured_html $_STDOUT_ $_STDERR_);
tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!;
tie *STDERR, 'IO::Catch', '_STDERR_' or die $!;
$SIG{__WARN__} = sub { $_STDERR_ .= join "", @_};
{ package HTML::Display::TempFile::Test;
use parent 'HTML::Display::TempFile';
sub browsercmd { qq{$^X -lne "" "%s" } };
};
SKIP: {
use_ok("HTML::Display");
$display = HTML::Display->new( class => 'HTML::Display::TempFile::Test' );
$display->display("# Hello World");
is($_STDERR_,undef,"Could launch tempfile program");
};
untie *STDOUT;
untie *STDERR;
HTML-Display-0.40/t/99-todo.t 0000755 0001750 0001750 00000001575 12162616301 015015 0 ustar corion corion use Test::More;
use File::Spec;
use File::Find;
use strict;
# Check that all files do not contain any
# lines with "XXX" - such markers should
# either have been converted into Todo-stuff
# or have been resolved.
# The test was provided by Andy Lester.
my @files;
my $blib = File::Spec->catfile(qw(blib lib));
find(\&wanted, $blib);
plan tests => scalar @files;
foreach my $file (@files) {
source_file_ok($file);
}
sub wanted {
push @files, $File::Find::name if /\.p(l|m|od)$/;
}
sub source_file_ok {
my $file = shift;
open( my $fh, "<", $file ) or die "Can't open $file: $!";
my @lines = <$fh>;
close $fh;
my $n = 0;
for ( @lines ) {
++$n;
s/^/$file ($n): /;
}
my @x = grep /XXX/, @lines;
if ( !is( scalar @x, 0, "Looking for XXXes in $file" ) ) {
diag( $_ ) for @x;
}
}
HTML-Display-0.40/t/99-unix-text.t 0000755 0001750 0001750 00000001357 12162616301 016013 0 ustar corion corion use Test::More;
# Check that all released module files are in
# UNIX text format
use File::Spec;
use File::Find;
use strict;
my @files;
my $blib = File::Spec->catfile(qw(blib lib));
find(\&wanted, $blib);
plan tests => scalar @files;
foreach my $file (@files) {
unix_file_ok($file);
}
sub wanted {
push @files, $File::Find::name if /\.p(l|m|od)$/;
}
sub unix_file_ok {
my ($filename) = @_;
local $/;
open F, "< $filename"
or die "Couldn't open '$filename' : $!\n";
binmode F;
my $content = ;
my $i;
my @lines = grep { /\x0D\x0A$/sm } map { sprintf "%s: %s\x0A", $i++, $_ } split /\x0A/, $content;
unless (is(scalar @lines, 0,"'$filename' contains no windows newlines")) {
diag $_ for @lines;
};
close F;
};
HTML-Display-0.40/t/embedded-HTML-Display-Win32-IE.t 0000755 0001750 0001750 00000002430 12162616301 020671 0 ustar corion corion #!/opt/perl58/bin/perl -w
use Test::More 'no_plan';
package Catch;
sub TIEHANDLE {
my($class, $var) = @_;
return bless { var => $var }, $class;
}
sub PRINT {
my($self) = shift;
${'main::'.$self->{var}} .= join '', @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
sub BINMODE {}
my $Original_File = 'lib/HTML/Display/Win32/IE.pm';
package main;
# pre-5.8.0's warns aren't caught by a tied STDERR.
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
tie *STDERR, 'Catch', '_STDERR_' or die $!;
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 14 lib/HTML/Display/Win32/IE.pm
my $browser = HTML::Display->new(
class => 'HTML::Display::Dump',
);
$browser->display("Hello world!
");
;
}
};
is($@, '', "example from line 14");
};
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
};
HTML-Display-0.40/t/embedded-HTML-Display-OSX-Safari.t 0000755 0001750 0001750 00000002434 12162616301 021354 0 ustar corion corion #!/opt/perl58/bin/perl -w
use Test::More 'no_plan';
package Catch;
sub TIEHANDLE {
my($class, $var) = @_;
return bless { var => $var }, $class;
}
sub PRINT {
my($self) = shift;
${'main::'.$self->{var}} .= join '', @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
sub BINMODE {}
my $Original_File = 'lib/HTML/Display/OSX/Safari.pm';
package main;
# pre-5.8.0's warns aren't caught by a tied STDERR.
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
tie *STDERR, 'Catch', '_STDERR_' or die $!;
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 13 lib/HTML/Display/OSX/Safari.pm
my $browser = HTML::Display->new(
class => 'HTML::Display::Dump',
);
$browser->display("Hello world!
");
;
}
};
is($@, '', "example from line 13");
};
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
};
HTML-Display-0.40/t/embedded-HTML-Display-Dump.t 0000755 0001750 0001750 00000004216 12162616301 020405 0 ustar corion corion #!/opt/perl58/bin/perl -w
use Test::More 'no_plan';
package Catch;
sub TIEHANDLE {
my($class, $var) = @_;
return bless { var => $var }, $class;
}
sub PRINT {
my($self) = shift;
${'main::'.$self->{var}} .= join '', @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
sub BINMODE {}
my $Original_File = 'lib/HTML/Display/Dump.pm';
package main;
# pre-5.8.0's warns aren't caught by a tied STDERR.
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
tie *STDERR, 'Catch', '_STDERR_' or die $!;
SKIP: {
# A header testing whether we find all prerequisites :
# Check for module HTML::Display
eval { require HTML::Display };
skip "Need module HTML::Display to run this test", 1
if $@;
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 13 lib/HTML/Display/Dump.pm
use HTML::Display;
my $browser = HTML::Display->new(
class => 'HTML::Display::Dump',
);
$browser->display("Hello world!
");
;
}
};
is($@, '', "example from line 13");
};
SKIP: {
# A header testing whether we find all prerequisites :
# Check for module HTML::Display
eval { require HTML::Display };
skip "Need module HTML::Display to run this test", 1
if $@;
# The original POD test
{
undef $main::_STDOUT_;
undef $main::_STDERR_;
#line 13 lib/HTML/Display/Dump.pm
use HTML::Display;
my $browser = HTML::Display->new(
class => 'HTML::Display::Dump',
);
$browser->display("Hello world!
");
isa_ok($browser,"HTML::Display::Common");
is($_STDOUT_,"Hello world!
","Dumped output");
is($_STDERR_,undef,"No warnings");
undef $main::_STDOUT_;
undef $main::_STDERR_;
}
};
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
};
HTML-Display-0.40/t/00-HTML-Display-use.t 0000755 0001750 0001750 00000005624 12162616301 016766 0 ustar corion corion use strict;
use Test::More tests => 16;
use vars qw( $display $captured_html );
{
package HTML::Display::Capture;
use parent 'HTML::Display::Common';
sub display_html { $::captured_html = $_[1]; };
};
sub display_ok {
my ($html,$base,$expected,$name) = @_;
undef $captured_html;
$display->display( html => $html, location => $base);
is($captured_html,$expected,$name);
};
SKIP: {
use_ok("HTML::Display");
$display = HTML::Display->new();
isa_ok($display,"HTML::Display::Common","Default class");
$display = HTML::Display->new( class => 'HTML::Display::Capture' );
isa_ok($display,"HTML::Display::Common");
# Now check our published API :
for my $meth (qw( display )) {
can_ok($display,$meth);
};
# Now check the handling of base tags :
display_ok("","http://example.com",'',"Empty head");
display_ok("","http://example.com",'',"Empty head without trailing slash");
display_ok('',"http://example.com",'',"Existing head");
display_ok('',"http://example.com",'',"Existing head");
display_ok('',"http://example.com/file.html",'',"Existing head 2");
display_ok('',"http://example.com/file.html",'',"Filename in base");
display_ok('',"http://example.com:666/file.html",'',"Port");
display_ok('','http://super:secret@example.com/file.html','',"Basic authentification");
display_ok('','http://example.com/','',"'target' attribute");
display_ok('','http://example.com/','',"No tag");
display_ok('foo','http://example.com/','foo',"No tag");
display_ok('','http://example.com/','',"Single tag");
};
HTML-Display-0.40/t/embedded-HTML-Display-Win32-OLE.t 0000755 0001750 0001750 00000003145 12162616301 021017 0 ustar corion corion #!/opt/perl58/bin/perl -w
use Test::More 'no_plan';
package Catch;
sub TIEHANDLE {
my($class, $var) = @_;
return bless { var => $var }, $class;
}
sub PRINT {
my($self) = shift;
${'main::'.$self->{var}} .= join '', @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
sub BINMODE {}
my $Original_File = 'lib/HTML/Display/Win32/OLE.pm';
package main;
# pre-5.8.0's warns aren't caught by a tied STDERR.
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
tie *STDERR, 'Catch', '_STDERR_' or die $!;
SKIP: {
# A header testing whether we find all prerequisites :
# Check for module base
eval { require base };
skip "Need module base to run this test", 1
if $@;
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 13 lib/HTML/Display/Win32/OLE.pm
package HTML::Display::Win32::OleControl;
use parent 'HTML::Display::Win32::OLE';
sub new {
my $class = shift;
$class->SUPER::new( app_string => "FooBrowser.Application", @_ );
$self;
};
my $browser = HTML::Display->new(
class => 'HTML::Display::Win32::OleControl',
);
$browser->display("Hello world!
");
;
}
};
is($@, '', "example from line 13");
};
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
};
HTML-Display-0.40/t/99-manifest.t 0000755 0001750 0001750 00000001072 12162616301 015646 0 ustar corion corion use strict;
use Test::More;
# Check that MANIFEST and MANIFEST.skip are sane :
use File::Find;
use File::Spec;
my @files = qw( MANIFEST MANIFEST.skip );
plan tests => scalar @files * 4;
for my $file (@files) {
ok(-f $file, "$file exists");
open F, "<$file"
or die "Couldn't open $file : $!";
my @lines = ;
is_deeply([grep(/^$/, @lines)],[], "No empty lines in $file");
is_deeply([grep(/^\s+$/, @lines)],[], "No whitespace-only lines in $file");
is_deeply([grep(/^\s*\S\s+$/, @lines)],[],"No trailing whitespace on lines in $file");
close F;
};
HTML-Display-0.40/t/99-pod.t 0000755 0001750 0001750 00000001245 12162616301 014624 0 ustar corion corion use Test::More;
# Check our Pod
# The test was provided by Andy Lester,
# who stole it from Brian D. Foy
# Thanks to both !
use File::Spec;
use File::Find;
use strict;
eval {
require Test::Pod;
Test::Pod->import;
};
my @files;
if ($@) {
plan skip_all => "Test::Pod required for testing POD";
}
elsif ($Test::Pod::VERSION < 0.95) {
plan skip_all => "Test::Pod 0.95 required for testing POD";
}
else {
my @dirs = grep { -d } (File::Spec->catfile(qw(blib lib)), 'bin', 'scripts');
find(\&wanted, @dirs);
plan tests => scalar @files;
foreach my $file (@files) {
pod_file_ok($file);
}
}
sub wanted {
push @files, $File::Find::name if /\.p(l|m|od)$/;
}
HTML-Display-0.40/t/embedded-HTML-Display-Galeon.t 0000755 0001750 0001750 00000002355 12162616301 020707 0 ustar corion corion #!/opt/perl58/bin/perl -w
use Test::More 'no_plan';
package Catch;
sub TIEHANDLE {
my($class, $var) = @_;
return bless { var => $var }, $class;
}
sub PRINT {
my($self) = shift;
${'main::'.$self->{var}} .= join '', @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
sub BINMODE {}
my $Original_File = 'lib/HTML/Display/Galeon.pm';
package main;
# pre-5.8.0's warns aren't caught by a tied STDERR.
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
tie *STDERR, 'Catch', '_STDERR_' or die $!;
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 13 lib/HTML/Display/Galeon.pm
my $browser = HTML::Display->new();
$browser->display("Hello world!
");
;
}
};
is($@, '', "example from line 13");
};
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
};
HTML-Display-0.40/t/embedded-HTML-Display.t 0000755 0001750 0001750 00000005055 12162616301 017504 0 ustar corion corion #!/opt/perl/bin/perl -w
use Test::More 'no_plan';
package Catch;
sub TIEHANDLE {
my($class, $var) = @_;
return bless { var => $var }, $class;
}
sub PRINT {
my($self) = shift;
${'main::'.$self->{var}} .= join '', @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
sub BINMODE {}
my $Original_File = 'lib/HTML/Display.pm';
package main;
# pre-5.8.0's warns aren't caught by a tied STDERR.
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
tie *STDERR, 'Catch', '_STDERR_' or die $!;
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 15 lib/HTML/Display.pm
my $html = "foo\n";
%HTML::Display::os_default = ();
delete $ENV{PERL_HTML_DISPLAY_CLASS};
use strict;
use HTML::Display;
# guess the best value from $ENV{PERL_HTML_DISPLAY_CLASS}
# or $ENV{PERL_HTML_DISPLAY_COMMAND}
# or the operating system, in that order
my $browser = HTML::Display->new();
warn "# Displaying HTML using " . ref $browser;
my $location = "http://www.google.com/";
$browser->display(html => $html, location => $location);
# Or, for a one-off job :
display("Hello world!
");
;
}
};
is($@, '', "example from line 15");
{
undef $main::_STDOUT_;
undef $main::_STDERR_;
#line 15 lib/HTML/Display.pm
my $html = "foo\n";
%HTML::Display::os_default = ();
delete $ENV{PERL_HTML_DISPLAY_CLASS};
use strict;
use HTML::Display;
# guess the best value from $ENV{PERL_HTML_DISPLAY_CLASS}
# or $ENV{PERL_HTML_DISPLAY_COMMAND}
# or the operating system, in that order
my $browser = HTML::Display->new();
warn "# Displaying HTML using " . ref $browser;
my $location = "http://www.google.com/";
$browser->display(html => $html, location => $location);
# Or, for a one-off job :
display("Hello world!
");
is($::_STDOUT_,"foo\nHello world!
");
undef $main::_STDOUT_;
undef $main::_STDERR_;
}
undef $main::_STDOUT_;
undef $main::_STDERR_;
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 81 lib/HTML/Display.pm
# Install class for MagicOS
$HTML::Display::os_default{"HTML::Display::MagicOS"}
= sub { $^O =~ qr/magic/i };
;
}
};
is($@, '', "example from line 81");
undef $main::_STDOUT_;
undef $main::_STDERR_;
HTML-Display-0.40/t/embedded-HTML-Display-Debian.t 0000755 0001750 0001750 00000002355 12162616301 020664 0 ustar corion corion #!/opt/perl58/bin/perl -w
use Test::More 'no_plan';
package Catch;
sub TIEHANDLE {
my($class, $var) = @_;
return bless { var => $var }, $class;
}
sub PRINT {
my($self) = shift;
${'main::'.$self->{var}} .= join '', @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
sub BINMODE {}
my $Original_File = 'lib/HTML/Display/Debian.pm';
package main;
# pre-5.8.0's warns aren't caught by a tied STDERR.
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
tie *STDERR, 'Catch', '_STDERR_' or die $!;
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 13 lib/HTML/Display/Debian.pm
my $browser = HTML::Display->new();
$browser->display("Hello world!
");
;
}
};
is($@, '', "example from line 13");
};
SKIP: {
# A header testing whether we find all prerequisites :
# The original POD test
undef $main::_STDOUT_;
undef $main::_STDERR_;
};
HTML-Display-0.40/lib/ 0000755 0001750 0001750 00000000000 12162617154 013723 5 ustar corion corion HTML-Display-0.40/lib/HTML/ 0000755 0001750 0001750 00000000000 12162617154 014467 5 ustar corion corion HTML-Display-0.40/lib/HTML/Display/ 0000755 0001750 0001750 00000000000 12162617154 016074 5 ustar corion corion HTML-Display-0.40/lib/HTML/Display/Win32.pm 0000644 0001750 0001750 00000001607 12162617127 017340 0 ustar corion corion package HTML::Display::Win32;
use strict;
use vars qw($VERSION);
$VERSION='0.40';
=head1 NAME
HTML::Display::Win32 - display an URL through the default application for HTML
=head1 SYNOPSIS
=for example begin
my $browser = HTML::Display->new();
$browser->display("Hello world!
");
=for example end
=head1 BUGS
Currently does not work.
Making it work will need either munging the tempfilename to
become ".html", or looking through the registry whether we find
a suitable application there.
=cut
use parent 'HTML::Display::TempFile';
sub browsercmd {
# cmd.exe needs two arguments, command.com needs one
($ENV{COMSPEC} =~ /cmd.exe$/i) ? 'start "HTML::Display" "%s"' : 'start "%s"'
};
=head1 AUTHOR
Copyright (c) 2004-2013 Max Maischein C<< >>
=head1 LICENSE
This module is released under the same terms as Perl itself.
=cut
1;
HTML-Display-0.40/lib/HTML/Display/OSX.pm 0000644 0001750 0001750 00000001112 12162617104 017071 0 ustar corion corion package HTML::Display::OSX;
use strict;
use parent 'HTML::Display::TempFile';
use vars qw($VERSION);
$VERSION='0.40';
=head1 NAME
HTML::Display::OSX - display HTML on OSX
=head1 SYNOPSIS
=for example begin
my $browser = HTML::Display->new();
$browser->display("Hello world!
");
=for example end
This launches the default browser on OSX.
=cut
sub browsercmd { "open %s" };
=head1 AUTHOR
Copyright (c) 2004-2013 Max Maischein C<< >>
=head1 LICENSE
This module is released under the same terms as Perl itself.
=cut
1;
HTML-Display-0.40/lib/HTML/Display/Common.pm 0000644 0001750 0001750 00000012626 12162617036 017670 0 ustar corion corion package HTML::Display::Common;
=head1 NAME
HTML::Display::Common - routines common to all HTML::Display subclasses
=cut
use strict;
use HTML::TokeParser;
use URI::URL;
use vars qw($VERSION);
$VERSION='0.40';
use Carp qw( croak );
=head2 __PACKAGE__-Enew %ARGS
Creates a new object as a blessed hash. The passed arguments are stored within
the hash. If you need to do other things in your constructor, remember to call
this constructor as well :
=for example
no warnings 'redefine';
*HTML::Display::WhizBang::display_html = sub {};
=for example begin
package HTML::Display::WhizBang;
use parent 'HTML::Display::Common';
sub new {
my ($class) = shift;
my %args = @_;
my $self = $class->SUPER::new(%args);
# do stuff
$self;
};
=for example end
=for example_testing
package main;
use HTML::Display;
my $browser = HTML::Display->new( class => "HTML::Display::WhizBang");
isa_ok($browser,"HTML::Display::Common");
=cut
sub new {
my ($class) = shift;
#croak "Odd number" if @_ % 2;
my $self = { @_ };
bless $self,$class;
$self;
};
=head2 $display->display %ARGS
This is the routine used to display the HTML to the user. It takes the
following parameters :
html => SCALAR containing the HTML
file => SCALAR containing the filename of the file to be displayed
base => optional base url for the HTML, so that relative links still work
location (synonymous to base)
=head3 Basic usage :
=for example
no warnings 'redefine';
*HTML::Display::new = sub {
my $class = shift;
require HTML::Display::Dump;
return HTML::Display::Dump->new(@_);
};
=for example begin
my $html = "Hello world!
";
my $browser = HTML::Display->new();
$browser->display( html => $html );
=for example end
=for example_testing
isa_ok($browser, "HTML::Display::Dump","The browser");
is( $main::_STDOUT_,"Hello world!
","HTML gets output");
=head3 Location parameter :
If you fetch a page from a remote site but still want to display
it to the user, the C parameter comes in very handy :
=for example
no warnings 'redefine';
*HTML::Display::new = sub {
my $class = shift;
require HTML::Display::Dump;
return HTML::Display::Dump->new(@_);
};
=for example begin
my $html = '';
my $browser = HTML::Display->new();
# This will display part of the Google logo
$browser->display( html => $html, base => 'http://www.google.com' );
=for example end
=for example_testing
isa_ok($browser, "HTML::Display::Dump","The browser");
is( $main::_STDOUT_,
'',
"HTML gets output");
$main::_STDOUT_ = "";
$browser->display( html => $html, location => 'http://www.google.com' );
is( $main::_STDOUT_,
'',
"HTML gets output");
=cut
sub display {
my ($self) = shift;
my %args;
if (scalar @_ == 1) {
%args = ( html => $_[0] );
} else {
%args = @_;
};
if ($args{file}) {
my $filename = delete $args{file};
local $/;
local *FILE;
open FILE, "<", $filename
or croak "Couldn't read $filename";
$args{html} = ;
};
$args{base} = delete $args{location}
if (! exists $args{base} and exists $args{location});
my $new_html;
if (exists $args{base}) {
# trim to directory create BASE HREF
# We are carefull to not trim if we just have http://domain.com
my $location = URI::URL->new( $args{base} );
my $path = $location->path;
$path =~ s%(?scheme, $location->authority , $path;
require HTML::TokeParser::Simple;
my $p = HTML::TokeParser::Simple->new(\$args{html}) || die 'could not create HTML::TokeParser::Simple object';
my ($has_head,$has_base);
while (my $token = $p->get_token) {
if ( $token->is_start_tag('head') ) {
$has_head++;
} elsif ( $token->is_start_tag('base')) {
$has_base++;
last;
};
};
# restart parsing
$p = HTML::TokeParser::Simple->new(\$args{html}) || die 'could not create HTML::TokeParser::Simple object';
while (my $token = $p->get_token) {
if ( $token->is_start_tag('html') and not $has_head) {
$new_html .= $token->as_is . qq{};
} elsif ( $token->is_start_tag('head') and not $has_base) {
# handle an empty :
if ($token->as_is =~ m!^<\s*head\s*/>$!i) {
$new_html .= qq{}
} else {
$new_html .= $token->as_is . qq{};
};
} elsif ( $token->is_start_tag('base') ) {
# If they already have a , give up
if ($token->return_attr->{href}) {
$new_html = $args{html};
last;
} else {
$token->set_attr('href',$location);
$new_html .= $token->as_is;
};
} else {
$new_html .= $token->as_is;
}
};
} else {
$new_html = $args{html};
};
$self->display_html($new_html);
};
=head1 AUTHOR
Copyright (c) 2004-2013 Max Maischein C<< >>
=head1 LICENSE
This module is released under the same terms as Perl itself.
=cut
1;
HTML-Display-0.40/lib/HTML/Display/TempFile.pm 0000644 0001750 0001750 00000002410 12162617121 020126 0 ustar corion corion package HTML::Display::TempFile;
use strict;
use parent 'HTML::Display::Common';
use vars qw($VERSION);
$VERSION='0.40';
=head1 NAME
HTML::Display::TempFile - base class to display HTML via a temporary file
=head1 SYNOPSIS
=for example begin
package HTML::Display::External;
use parent 'HTML::Display::TempFile';
sub browsercmd {
# Return the string to pass to system()
# %s will be replaced by the temp file name
};
=for example end
=cut
sub display_html {
# We need to use a temp file for communication
my ($self,$html) = @_;
$self->cleanup_tempfiles;
require File::Temp;
my($tempfh, $tempfile) = File::Temp::tempfile(SUFFIX => '.html');
print $tempfh $html;
close $tempfh;
push @{$self->{delete}}, $tempfile;
my $cmdline = sprintf($self->browsercmd, $tempfile);
system( $cmdline ) == 0
or warn "Couldn't launch '$cmdline' : $?";
};
sub cleanup_tempfiles {
my ($self) = @_;
for my $file (@{$self->{delete}}) {
unlink $file
or warn "Couldn't remove tempfile $file : $!\n";
};
$self->{delete} = [];
};
sub browsercmd { $_[0]->{browsercmd} };
=head1 AUTHOR
Copyright (c) 2004-2013 Max Maischein C<< >>
=head1 LICENSE
This module is released under the same terms as Perl itself.
=cut
1;
HTML-Display-0.40/lib/HTML/Display/Debian.pm 0000644 0001750 0001750 00000001273 12162617053 017615 0 ustar corion corion package HTML::Display::Debian;
use strict;
use parent 'HTML::Display::TempFile';
use vars qw($VERSION);
$VERSION='0.40';
=head1 NAME
HTML::Display::Debian - display HTML using the Debian default
=head1 SYNOPSIS
=for example begin
my $browser = HTML::Display->new();
$browser->display("Hello world!
");
=for example end
This module implements displaying HTML through the Debian default web browser
referenced as the program C.
=cut
sub browsercmd { "x-www-browser %s" };
=head1 AUTHOR
Copyright (c) 2004-2013 Max Maischein C<< >>
=head1 LICENSE
This module is released under the same terms as Perl itself.
=cut
1;
HTML-Display-0.40/lib/HTML/Display/Mozilla.pm 0000644 0001750 0001750 00000001106 12162617073 020037 0 ustar corion corion package HTML::Display::Mozilla;
use strict;
use parent 'HTML::Display::TempFile';
use vars qw($VERSION);
$VERSION='0.40';
=head1 NAME
HTML::Display::Mozilla - display HTML through Mozilla
=head1 SYNOPSIS
=for example begin
my $browser = HTML::Display->new();
$browser->display("Hello world!
");
=for example end
=cut
sub browsercmd { 'mozilla -remote "openURL(%s)"' };
=head1 AUTHOR
Copyright (c) 2004-2013 Max Maischein C<< >>
=head1 LICENSE
This module is released under the same terms as Perl itself.
=cut
1;
HTML-Display-0.40/lib/HTML/Display/Dump.pm 0000644 0001750 0001750 00000001461 12162617056 017342 0 ustar corion corion package HTML::Display::Dump;
use strict;
use parent 'HTML::Display::Common';
use vars qw($VERSION);
$VERSION='0.40';
=head1 NAME
HTML::Display::Dump - dump raw HTML to the console
=head1 SYNOPSIS
=for example
use HTML::Display;
=for example begin
my $browser = HTML::Display->new(
class => 'HTML::Display::Dump',
);
$browser->display("Hello world!
");
=for example end
=for example_testing
isa_ok($browser,"HTML::Display::Common");
is($_STDOUT_,"Hello world!
","Dumped output");
is($_STDERR_,undef,"No warnings");
=cut
sub display_html { print $_[1]; };
=head1 AUTHOR
Copyright (c) 2004-2013 Max Maischein C<< >>
=head1 LICENSE
This module is released under the same terms as Perl itself.
=cut
1;
HTML-Display-0.40/lib/HTML/Display/Win32/ 0000755 0001750 0001750 00000000000 12162617154 016776 5 ustar corion corion HTML-Display-0.40/lib/HTML/Display/Win32/IE.pm 0000644 0001750 0001750 00000002310 12162616612 017623 0 ustar corion corion package HTML::Display::Win32::IE;
use strict;
use Carp qw(carp);
use parent 'HTML::Display::Win32::OLE';
use vars qw($VERSION);
$VERSION='0.40';
=head1 NAME
HTML::Display::Win32::IE - use IE to display HTML pages
=head1 SYNOPSIS
=for example begin
my $browser = HTML::Display->new(
class => 'HTML::Display::Dump',
);
$browser->display("Hello world!
");
=for example end
This implementation avoids temporary files by using OLE to push
the HTML directly into the browser.
=cut
sub new {
my ($class) = @_;
my $self = $class->SUPER::new( app_string => "InternetExplorer.Application" );
$self;
};
sub setup {
my ($self,$control) = @_;
#warn "Setting up browser";
$control->{'Visible'} = 1;
$control->Navigate('about:blank');
};
sub display_html {
my ($self,$html) = @_;
if ($html) {
my $browser = $self->control;
my $document = $browser->{Document};
$document->open("text/html","replace");
$document->write($html);
} else {
carp "No HTML given" unless $html;
};
};
=head1 AUTHOR
Copyright (c) 2004-2007 Max Maischein C<< >>
=head1 LICENSE
This module is released under the same terms as Perl itself.
=cut
1;
HTML-Display-0.40/lib/HTML/Display/Win32/OLE.pm 0000644 0001750 0001750 00000002765 12162616612 017763 0 ustar corion corion package HTML::Display::Win32::OLE;
use strict;
use parent 'HTML::Display::Common';
use vars qw($VERSION);
$VERSION='0.40';
=head1 NAME
HTML::Display::Win32::OLE - use an OLE object to display HTML
=head1 SYNOPSIS
=for example begin
package HTML::Display::Win32::OleControl;
use parent 'HTML::Display::Win32::OLE';
sub new {
my $class = shift;
$class->SUPER::new( app_string => "FooBrowser.Application", @_ );
$self;
};
my $browser = HTML::Display->new(
class => 'HTML::Display::Win32::OleControl',
);
$browser->display("Hello world!
");
=for example end
=cut
sub new {
my ($class) = shift;
my %args = @_;
my $self = $class->SUPER::new( %args );
$self;
};
=head2 setup
C is a method you can override to provide initial
setup of your OLE control. It is called after the control
is instantiated for the first time.
=cut
sub setup {};
=head2 control
This initializes the OLE control and returns it. Only one
control is initialized for each object instance. You don't need
to store it separately.
=cut
sub control {
my $self = shift;
unless ($self->{control}) {
eval "use Win32::OLE";
die $@ if $@;
my $control = Win32::OLE->CreateObject($self->{app_string});
$self->{control} = $control;
$self->setup($control);
};
$self->{control};
};
=head1 AUTHOR
Copyright (c) 2004-2007 Max Maischein C<< >>
=head1 LICENSE
This module is released under the same terms as Perl itself.
=cut
1;
HTML-Display-0.40/lib/HTML/Display/Phoenix.pm 0000644 0001750 0001750 00000001063 12162617115 020041 0 ustar corion corion package HTML::Display::Phoenix;
use strict;
use parent 'HTML::Display::TempFile';
use vars qw($VERSION);
$VERSION='0.40';
=head1 NAME
HTML::Display::Phoenix - display HTML through Phoenix
=head1 SYNOPSIS
=for example begin
my $browser = HTML::Display->new();
$browser->display("Hello world!
");
=for example end
=cut
sub browsercmd { "phoenix %s" };
=head1 AUTHOR
Copyright (c) 2004-2013 Max Maischein C<< >>
=head1 LICENSE
This module is released under the same terms as Perl itself.
=cut
1;
HTML-Display-0.40/lib/HTML/Display/Opera.pm 0000644 0001750 0001750 00000001166 12162617100 017473 0 ustar corion corion package HTML::Display::Opera;
use strict;
use parent 'HTML::Display::TempFile';
use vars qw($VERSION);
$VERSION='0.40';
=head1 NAME
HTML::Display::Galeon - display HTML through Galeon
=head1 SYNOPSIS
=for example begin
my $browser = HTML::Display->new();
$browser->display("Hello world!
");
=for example end
=head1 ACKNOWLEDGEMENTS
Tina Mueller provided the browser command line
=cut
sub browsercmd { "opera %s" };
=head1 AUTHOR
Copyright (c) 2004-2013 Max Maischein C<< >>
=head1 LICENSE
This module is released under the same terms as Perl itself.
=cut
1;
HTML-Display-0.40/lib/HTML/Display/Galeon.pm 0000644 0001750 0001750 00000001062 12162617063 017635 0 ustar corion corion package HTML::Display::Galeon;
use strict;
use parent 'HTML::Display::TempFile';
use vars qw($VERSION);
$VERSION='0.40';
=head1 NAME
HTML::Display::Galeon - display HTML through Galeon
=head1 SYNOPSIS
=for example begin
my $browser = HTML::Display->new();
$browser->display("Hello world!
");
=for example end
=cut
sub browsercmd { "galeon -n %s" };
=head1 AUTHOR
Copyright (c) 2004-2013 Max Maischein C<< >>
=head1 LICENSE
This module is released under the same terms as Perl itself.
=cut
1;
HTML-Display-0.40/lib/HTML/Display.pm 0000644 0001750 0001750 00000012376 12162616612 016441 0 ustar corion corion package HTML::Display;
use strict;
use HTML::TokeParser;
use Carp qw( croak );
use vars qw( $VERSION );
$VERSION='0.40';
=head1 NAME
HTML::Display - display HTML locally in a browser
=head1 SYNOPSIS
=for example
my $html = "foo\n";
%HTML::Display::os_default = ();
delete $ENV{PERL_HTML_DISPLAY_CLASS};
=for example begin
use strict;
use HTML::Display;
# guess the best value from $ENV{PERL_HTML_DISPLAY_CLASS}
# or $ENV{PERL_HTML_DISPLAY_COMMAND}
# or the operating system, in that order
my $browser = HTML::Display->new();
warn "# Displaying HTML using " . ref $browser;
my $location = "http://www.google.com/";
$browser->display(html => $html, location => $location);
# Or, for a one-off job :
display("Hello world!
");
=for example end
=for example_testing
is($::_STDOUT_,"foo\nHello world!
");
=head1 DESCRIPTION
This module abstracts the task of displaying HTML to the user. The
displaying is done by launching a browser and navigating it to either
a temporary file with the HTML stored in it, or, if possible, by
pushing the HTML directly into the browser window.
The module tries to automagically select the "correct" browser, but
if it dosen't find a good browser, you can modify the behaviour by
setting some environment variables :
PERL_HTML_DISPLAY_CLASS
If HTML::Display already provides a class for the browser you want to
use, setting C to the name of the class will
make HTML::Display use that class instead of what it detects.
PERL_HTML_DISPLAY_COMMAND
If there is no specialized class yet, but your browser can be controlled
via the command line, then setting C to the
string to navigate to the URL will make HTML::Display use a C
call to the string. A C<%s> in the value will be replaced with the name
of the temporary file containing the HTML to display.
=cut
use vars qw( @ISA @EXPORT %os_default );
require Exporter;
@ISA='Exporter';
@EXPORT = qw( display );
=head2 %HTML::Display::os_default
The hash C<%HTML::Display::os_default> contains pairs of class names
for the different operating systems and routines that test whether
this script is currently running under it. If you you want to dynamically
add a new class or replace a class (or the rule), modify C<%os_default> :
=for example begin
# Install class for MagicOS
$HTML::Display::os_default{"HTML::Display::MagicOS"}
= sub { $^O =~ qr/magic/i };
=for example end
=cut
%os_default = (
"HTML::Display::Win32::IE" => sub {
my $have_ole;
eval {
require Win32::OLE;
Win32::OLE->import();
$have_ole = 1;
};
$have_ole and $^O =~ qr/mswin32/i
},
"HTML::Display::Debian" => sub { -x "/usr/bin/x-www-browser" },
"HTML::Display::OSX" => sub { $^O =~ qr/darwin/i },
);
=head2 __PACKAGE__->new %ARGS
=cut
sub new {
my $class = shift;
my (%args) = @_;
# First see whether the programmer or user specified a class
my $best_class = delete $args{class} || $ENV{PERL_HTML_DISPLAY_CLASS};
# Now, did they specify a command?
unless ($best_class) {
my $command = delete $args{browsercmd} || $ENV{PERL_HTML_DISPLAY_COMMAND};
if ($command) {
$best_class = "HTML::Display::TempFile";
$args{browsercmd} = $command;
@_ = %args;
};
};
unless ($best_class) {
for my $class (sort keys %os_default) {
$best_class = $class
if $os_default{$class}->();
};
};
$best_class ||= "HTML::Display::Dump";
{ no strict 'refs';
undef $@;
eval "use $best_class;"
unless ( @{"${best_class}::ISA"}
or defined *{"${best_class}::new"}{CODE}
or defined *{"${best_class}::AUTOLOAD"}{CODE});
croak "While trying to load $best_class: $@" if $@;
};
return $best_class->new(@_);
};
=head2 $browser-Edisplay( %ARGS )
Will display the HTML. The following arguments are valid :
base => Base to which all relative links will be resolved
html => Scalar containing the HTML to be displayed
file => Scalar containing the name of the file to be displayed
This file will possibly be copied into a temporary file!
location (synonymous to base)
If only one argument is passed, then it is taken as if
html => $_[0]
was passed.
=cut
sub display {
my %args;
if (scalar @_ == 1) {
%args = ( html => @_ )
} else {
%args = @_
};
HTML::Display->new()->display( %args );
};
=head1 EXPORTS
The subroutine C is exported by default
=head1 COMMAND LINE USAGE
Display some HTML to the user :
perl -MHTML::Display -e "display 'Hello world'"
Display a web page to the user :
perl -MLWP::Simple -MHTML::Display -e "display get 'http://www.google.com'"
Display the same page with the images also working :
perl -MLWP::Simple -MHTML::Display -e "display html => get('http://www.google.com'),
location => 'http://www.google.com'"
=head1 AUTHOR
Copyright (c) 2004-2007 Max Maischein C<< >>
=head1 LICENSE
This module is released under the same terms as Perl itself.
=cut
1;