├── t
├── fixtures
│ ├── example.css
│ ├── mock_wkhtmltopdf
│ ├── mock_wkhtmltopdf.bat
│ └── example.html
├── spec_helper.pl
├── pdf-webkit-source.t
├── pdf-webkit-integration.t
└── pdf-webkit.t
├── .gitignore
├── Makefile.PL
├── MANIFEST
├── lib
└── PDF
│ ├── WebKit
│ ├── Source.pm
│ └── Configuration.pm
│ └── WebKit.pm
├── README
├── Changes
└── inc
└── Module
├── Install
├── Base.pm
├── WriteAll.pm
├── Win32.pm
├── Can.pm
├── Fetch.pm
├── Makefile.pm
└── Metadata.pm
└── Install.pm
/t/fixtures/example.css:
--------------------------------------------------------------------------------
1 | body { font-size: 20px; }
--------------------------------------------------------------------------------
/t/fixtures/mock_wkhtmltopdf:
--------------------------------------------------------------------------------
1 | #!/usr/bin/env bash
2 | true
3 |
--------------------------------------------------------------------------------
/t/fixtures/mock_wkhtmltopdf.bat:
--------------------------------------------------------------------------------
1 | @%COMSPEC% /C exit 1 >nul
2 |
--------------------------------------------------------------------------------
/t/fixtures/example.html:
--------------------------------------------------------------------------------
1 |
2 |
3 | Oh Hai!
4 |
5 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | Build
2 | MYMETA.yml
3 | _build
4 | blib
5 | META.yml
6 | Makefile
7 | pm_to_blib
8 | *.bak
9 | Makefile.old
10 | *.tar.gz
11 | local
12 | MYMETA.*
13 |
--------------------------------------------------------------------------------
/Makefile.PL:
--------------------------------------------------------------------------------
1 | #!perl
2 |
3 | use inc::Module::Install;
4 |
5 | # Define metadata
6 | name 'PDF-WebKit';
7 | all_from 'lib/PDF/WebKit.pm';
8 | license 'perl';
9 |
10 | # Specific dependencies
11 | requires 'IPC::Run3';
12 | requires 'Moo';
13 | requires 'namespace::clean';
14 | recommends 'XML::LibXML' => '1.62';
15 | test_requires 'Test::Spec';
16 |
17 | # Create Makefile
18 | WriteAll();
19 |
--------------------------------------------------------------------------------
/t/spec_helper.pl:
--------------------------------------------------------------------------------
1 | require File::Basename;
2 | require File::Spec;
3 |
4 | our $SPEC_ROOT = File::Basename::dirname(__FILE__);
5 | unshift @INC, $SPEC_ROOT;
6 | unshift @INC, File::Spec->catfile($SPEC_ROOT,"..","lib");
7 |
8 | require PDF::WebKit;
9 |
10 | sub index_of ($\@) {
11 | my ($what,$array) = @_;
12 | for (my $i = 0; $i < @$array; $i++) {
13 | return $i if $array->[$i] eq $what;
14 | }
15 | return undef;
16 | }
17 |
18 |
--------------------------------------------------------------------------------
/MANIFEST:
--------------------------------------------------------------------------------
1 | Changes
2 | inc/Module/Install.pm
3 | inc/Module/Install/Base.pm
4 | inc/Module/Install/Can.pm
5 | inc/Module/Install/Fetch.pm
6 | inc/Module/Install/Makefile.pm
7 | inc/Module/Install/Metadata.pm
8 | inc/Module/Install/Win32.pm
9 | inc/Module/Install/WriteAll.pm
10 | lib/PDF/WebKit.pm
11 | lib/PDF/WebKit/Configuration.pm
12 | lib/PDF/WebKit/Source.pm
13 | Makefile.PL
14 | MANIFEST This list of files
15 | README
16 | t/fixtures/example.css
17 | t/fixtures/example.html
18 | t/fixtures/mock_wkhtmltopdf
19 | t/fixtures/mock_wkhtmltopdf.bat
20 | t/pdf-webkit-integration.t
21 | t/pdf-webkit-source.t
22 | t/pdf-webkit.t
23 | t/spec_helper.pl
24 |
--------------------------------------------------------------------------------
/lib/PDF/WebKit/Source.pm:
--------------------------------------------------------------------------------
1 | package PDF::WebKit::Source;
2 | use strict;
3 | use warnings;
4 |
5 | use Moo;
6 | use namespace::clean;
7 |
8 | has string => ( is => 'rw' );
9 |
10 | around 'BUILDARGS' => sub {
11 | my $orig = shift;
12 | my $class = shift;
13 | if (@_ != 1) {
14 | die "Usage: ${class}->new(\$source)\n";
15 | }
16 |
17 | my $string = shift;
18 | return $class->$orig({ string => $string });
19 | };
20 |
21 | sub is_url {
22 | my $self = shift;
23 | return (!ref($self->string) && $self->string =~ /^https?:/i);
24 | }
25 |
26 | sub is_file {
27 | my $self = shift;
28 | return (!ref($self->string) && !$self->is_url);
29 | }
30 |
31 | sub is_html {
32 | my $self = shift;
33 | return ref($self->string) eq 'SCALAR';
34 | }
35 |
36 | sub content {
37 | my $self = shift;
38 | return ref($self->string) ? ${$self->string} : $self->string;
39 | }
40 |
41 | 1;
42 |
43 |
--------------------------------------------------------------------------------
/README:
--------------------------------------------------------------------------------
1 |
2 | PDF-WebKit version 1.2
3 | =======================
4 |
5 |
6 | Use WebKit to Generate PDFs from HTML (via wkhtmltopdf)
7 |
8 | my $pdf = PDF::WebKit->new('http://www.google.com/')->to_pdf;
9 |
10 | HOMEPAGE
11 |
12 | http://github.com/kingpong/perl-PDF-WebKit
13 |
14 | INSTALLATION
15 |
16 | To install this module type the following:
17 |
18 | perl Makefile.PL
19 | make
20 | make test
21 | make install
22 |
23 | DEPENDENCIES
24 |
25 | This module requires these other modules and libraries:
26 |
27 | * IPC::Run3
28 | * Moo
29 | * XML::LibXML 1.62 (recommended)
30 |
31 | To run the tests, you'll need:
32 |
33 | * Test::Spec
34 |
35 | COPYRIGHT AND LICENCE
36 |
37 | Copyright (C) 2011 by Informatics Corporation of America.
38 |
39 | This library is free software; you can redistribute it and/or modify
40 | it under the same terms as Perl itself, either Perl version 5.8.9 or,
41 | at your option, any later version of Perl 5 you may have available.
42 |
43 |
44 |
--------------------------------------------------------------------------------
/Changes:
--------------------------------------------------------------------------------
1 | Revision history for Perl extension PDF::WebKit.
2 |
3 | 1.2 Sun Feb 21 19:40:00 2018
4 | - Switch from IPC::Run to IPC::Run3 to get binmode and prevent
5 | corrupted PDFs on Win32. fixes gh#5
6 |
7 | 1.1 Sun Feb 04 21:41:00 2018
8 | - Incorporate Win32 fixes from @wchristian
9 |
10 | 1.0 Thu Apr 16 12:48:00 2015
11 | - Bumping to version 1.0 after only 4 stable years.
12 | - Documentation fix (issue #2)
13 |
14 | 0.9 Thu May 26 23:22:00 2011
15 | - Fixed bug that randomly prevented user or meta options from
16 | overriding the defaults, based on hashing (non)order.
17 |
18 | 0.8 Thu May 26 17:05:00 2011
19 | - Raised required version of XML::LibXML to 1.62 since that is the
20 | first version that allows options to parse_html_string().
21 |
22 | 0.7 Tue May 24 19:34:26 2011
23 | - Switched from IPC::Open2 to IPC::Run to get correct behavior under
24 | mod_perl 2.
25 |
26 | 0.01 Wed May 18 18:24:45 2011
27 | - original version; created by h2xs 1.23 with options
28 | -A -X -n PDF::WebKit
29 |
30 |
--------------------------------------------------------------------------------
/inc/Module/Install/Base.pm:
--------------------------------------------------------------------------------
1 | #line 1
2 | package Module::Install::Base;
3 |
4 | use strict 'vars';
5 | use vars qw{$VERSION};
6 | BEGIN {
7 | $VERSION = '1.01';
8 | }
9 |
10 | # Suspend handler for "redefined" warnings
11 | BEGIN {
12 | my $w = $SIG{__WARN__};
13 | $SIG{__WARN__} = sub { $w };
14 | }
15 |
16 | #line 42
17 |
18 | sub new {
19 | my $class = shift;
20 | unless ( defined &{"${class}::call"} ) {
21 | *{"${class}::call"} = sub { shift->_top->call(@_) };
22 | }
23 | unless ( defined &{"${class}::load"} ) {
24 | *{"${class}::load"} = sub { shift->_top->load(@_) };
25 | }
26 | bless { @_ }, $class;
27 | }
28 |
29 | #line 61
30 |
31 | sub AUTOLOAD {
32 | local $@;
33 | my $func = eval { shift->_top->autoload } or return;
34 | goto &$func;
35 | }
36 |
37 | #line 75
38 |
39 | sub _top {
40 | $_[0]->{_top};
41 | }
42 |
43 | #line 90
44 |
45 | sub admin {
46 | $_[0]->_top->{admin}
47 | or
48 | Module::Install::Base::FakeAdmin->new;
49 | }
50 |
51 | #line 106
52 |
53 | sub is_admin {
54 | ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin');
55 | }
56 |
57 | sub DESTROY {}
58 |
59 | package Module::Install::Base::FakeAdmin;
60 |
61 | use vars qw{$VERSION};
62 | BEGIN {
63 | $VERSION = $Module::Install::Base::VERSION;
64 | }
65 |
66 | my $fake;
67 |
68 | sub new {
69 | $fake ||= bless(\@_, $_[0]);
70 | }
71 |
72 | sub AUTOLOAD {}
73 |
74 | sub DESTROY {}
75 |
76 | # Restore warning handler
77 | BEGIN {
78 | $SIG{__WARN__} = $SIG{__WARN__}->();
79 | }
80 |
81 | 1;
82 |
83 | #line 159
84 |
--------------------------------------------------------------------------------
/lib/PDF/WebKit/Configuration.pm:
--------------------------------------------------------------------------------
1 | package PDF::WebKit::Configuration;
2 | use strict;
3 | use warnings;
4 | use Moo;
5 | use namespace::clean;
6 |
7 | has meta_tag_prefix => ( is => 'rw' );
8 | has default_options => ( is => 'rw' );
9 | has wkhtmltopdf => ( is => 'rw', builder => '_find_wkhtmltopdf', lazy => 1 );
10 |
11 | around 'BUILDARGS' => sub {
12 | my $orig = shift;
13 | my $self = shift;
14 | my $page_size = $ENV{LC_PAPER} || "";
15 | if ($page_size =~ m/^297\b/) {
16 | $page_size = "A4";
17 | }
18 | if (!$page_size && open my $fh, "<", "/etc/papersize") {
19 | chomp ($page_size = uc <$fh>);
20 | close $fh;
21 | }
22 | return $self->$orig({
23 | meta_tag_prefix => 'pdf-webkit-',
24 | default_options => {
25 | disable_smart_shrinking => undef,
26 | page_size => $page_size || 'Letter',
27 | margin_top => '0.75in',
28 | margin_right => '0.75in',
29 | margin_bottom => '0.75in',
30 | margin_left => '0.75in',
31 | encoding => "UTF-8",
32 | },
33 | });
34 | };
35 |
36 | sub _find_wkhtmltopdf {
37 | my $self = shift;
38 | my $which = $^O eq "MSWin32" ? "where" : "which";
39 | my $found = `$which wkhtmltopdf`;
40 | $? and return;
41 |
42 | chomp($found);
43 | return $found;
44 | }
45 |
46 | my $_config;
47 | sub configuration {
48 | $_config ||= PDF::WebKit::Configuration->new;
49 | }
50 |
51 | sub configure {
52 | my $class = shift;
53 | my $code = shift;
54 | local $_ = $class->configuration;
55 | $code->($_);
56 | }
57 |
58 | 1;
59 |
--------------------------------------------------------------------------------
/inc/Module/Install/WriteAll.pm:
--------------------------------------------------------------------------------
1 | #line 1
2 | package Module::Install::WriteAll;
3 |
4 | use strict;
5 | use Module::Install::Base ();
6 |
7 | use vars qw{$VERSION @ISA $ISCORE};
8 | BEGIN {
9 | $VERSION = '1.01';
10 | @ISA = qw{Module::Install::Base};
11 | $ISCORE = 1;
12 | }
13 |
14 | sub WriteAll {
15 | my $self = shift;
16 | my %args = (
17 | meta => 1,
18 | sign => 0,
19 | inline => 0,
20 | check_nmake => 1,
21 | @_,
22 | );
23 |
24 | $self->sign(1) if $args{sign};
25 | $self->admin->WriteAll(%args) if $self->is_admin;
26 |
27 | $self->check_nmake if $args{check_nmake};
28 | unless ( $self->makemaker_args->{PL_FILES} ) {
29 | # XXX: This still may be a bit over-defensive...
30 | unless ($self->makemaker(6.25)) {
31 | $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL';
32 | }
33 | }
34 |
35 | # Until ExtUtils::MakeMaker support MYMETA.yml, make sure
36 | # we clean it up properly ourself.
37 | $self->realclean_files('MYMETA.yml');
38 |
39 | if ( $args{inline} ) {
40 | $self->Inline->write;
41 | } else {
42 | $self->Makefile->write;
43 | }
44 |
45 | # The Makefile write process adds a couple of dependencies,
46 | # so write the META.yml files after the Makefile.
47 | if ( $args{meta} ) {
48 | $self->Meta->write;
49 | }
50 |
51 | # Experimental support for MYMETA
52 | if ( $ENV{X_MYMETA} ) {
53 | if ( $ENV{X_MYMETA} eq 'JSON' ) {
54 | $self->Meta->write_mymeta_json;
55 | } else {
56 | $self->Meta->write_mymeta_yaml;
57 | }
58 | }
59 |
60 | return 1;
61 | }
62 |
63 | 1;
64 |
--------------------------------------------------------------------------------
/inc/Module/Install/Win32.pm:
--------------------------------------------------------------------------------
1 | #line 1
2 | package Module::Install::Win32;
3 |
4 | use strict;
5 | use Module::Install::Base ();
6 |
7 | use vars qw{$VERSION @ISA $ISCORE};
8 | BEGIN {
9 | $VERSION = '1.01';
10 | @ISA = 'Module::Install::Base';
11 | $ISCORE = 1;
12 | }
13 |
14 | # determine if the user needs nmake, and download it if needed
15 | sub check_nmake {
16 | my $self = shift;
17 | $self->load('can_run');
18 | $self->load('get_file');
19 |
20 | require Config;
21 | return unless (
22 | $^O eq 'MSWin32' and
23 | $Config::Config{make} and
24 | $Config::Config{make} =~ /^nmake\b/i and
25 | ! $self->can_run('nmake')
26 | );
27 |
28 | print "The required 'nmake' executable not found, fetching it...\n";
29 |
30 | require File::Basename;
31 | my $rv = $self->get_file(
32 | url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
33 | ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
34 | local_dir => File::Basename::dirname($^X),
35 | size => 51928,
36 | run => 'Nmake15.exe /o > nul',
37 | check_for => 'Nmake.exe',
38 | remove => 1,
39 | );
40 |
41 | die <<'END_MESSAGE' unless $rv;
42 |
43 | -------------------------------------------------------------------------------
44 |
45 | Since you are using Microsoft Windows, you will need the 'nmake' utility
46 | before installation. It's available at:
47 |
48 | http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
49 | or
50 | ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
51 |
52 | Please download the file manually, save it to a directory in %PATH% (e.g.
53 | C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
54 | that directory, and run "Nmake15.exe" from there; that will create the
55 | 'nmake.exe' file needed by this module.
56 |
57 | You may then resume the installation process described in README.
58 |
59 | -------------------------------------------------------------------------------
60 | END_MESSAGE
61 |
62 | }
63 |
64 | 1;
65 |
--------------------------------------------------------------------------------
/inc/Module/Install/Can.pm:
--------------------------------------------------------------------------------
1 | #line 1
2 | package Module::Install::Can;
3 |
4 | use strict;
5 | use Config ();
6 | use File::Spec ();
7 | use ExtUtils::MakeMaker ();
8 | use Module::Install::Base ();
9 |
10 | use vars qw{$VERSION @ISA $ISCORE};
11 | BEGIN {
12 | $VERSION = '1.01';
13 | @ISA = 'Module::Install::Base';
14 | $ISCORE = 1;
15 | }
16 |
17 | # check if we can load some module
18 | ### Upgrade this to not have to load the module if possible
19 | sub can_use {
20 | my ($self, $mod, $ver) = @_;
21 | $mod =~ s{::|\\}{/}g;
22 | $mod .= '.pm' unless $mod =~ /\.pm$/i;
23 |
24 | my $pkg = $mod;
25 | $pkg =~ s{/}{::}g;
26 | $pkg =~ s{\.pm$}{}i;
27 |
28 | local $@;
29 | eval { require $mod; $pkg->VERSION($ver || 0); 1 };
30 | }
31 |
32 | # check if we can run some command
33 | sub can_run {
34 | my ($self, $cmd) = @_;
35 |
36 | my $_cmd = $cmd;
37 | return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
38 |
39 | for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
40 | next if $dir eq '';
41 | my $abs = File::Spec->catfile($dir, $_[1]);
42 | return $abs if (-x $abs or $abs = MM->maybe_command($abs));
43 | }
44 |
45 | return;
46 | }
47 |
48 | # can we locate a (the) C compiler
49 | sub can_cc {
50 | my $self = shift;
51 | my @chunks = split(/ /, $Config::Config{cc}) or return;
52 |
53 | # $Config{cc} may contain args; try to find out the program part
54 | while (@chunks) {
55 | return $self->can_run("@chunks") || (pop(@chunks), next);
56 | }
57 |
58 | return;
59 | }
60 |
61 | # Fix Cygwin bug on maybe_command();
62 | if ( $^O eq 'cygwin' ) {
63 | require ExtUtils::MM_Cygwin;
64 | require ExtUtils::MM_Win32;
65 | if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
66 | *ExtUtils::MM_Cygwin::maybe_command = sub {
67 | my ($self, $file) = @_;
68 | if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
69 | ExtUtils::MM_Win32->maybe_command($file);
70 | } else {
71 | ExtUtils::MM_Unix->maybe_command($file);
72 | }
73 | }
74 | }
75 | }
76 |
77 | 1;
78 |
79 | __END__
80 |
81 | #line 156
82 |
--------------------------------------------------------------------------------
/inc/Module/Install/Fetch.pm:
--------------------------------------------------------------------------------
1 | #line 1
2 | package Module::Install::Fetch;
3 |
4 | use strict;
5 | use Module::Install::Base ();
6 |
7 | use vars qw{$VERSION @ISA $ISCORE};
8 | BEGIN {
9 | $VERSION = '1.01';
10 | @ISA = 'Module::Install::Base';
11 | $ISCORE = 1;
12 | }
13 |
14 | sub get_file {
15 | my ($self, %args) = @_;
16 | my ($scheme, $host, $path, $file) =
17 | $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
18 |
19 | if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
20 | $args{url} = $args{ftp_url}
21 | or (warn("LWP support unavailable!\n"), return);
22 | ($scheme, $host, $path, $file) =
23 | $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
24 | }
25 |
26 | $|++;
27 | print "Fetching '$file' from $host... ";
28 |
29 | unless (eval { require Socket; Socket::inet_aton($host) }) {
30 | warn "'$host' resolve failed!\n";
31 | return;
32 | }
33 |
34 | return unless $scheme eq 'ftp' or $scheme eq 'http';
35 |
36 | require Cwd;
37 | my $dir = Cwd::getcwd();
38 | chdir $args{local_dir} or return if exists $args{local_dir};
39 |
40 | if (eval { require LWP::Simple; 1 }) {
41 | LWP::Simple::mirror($args{url}, $file);
42 | }
43 | elsif (eval { require Net::FTP; 1 }) { eval {
44 | # use Net::FTP to get past firewall
45 | my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
46 | $ftp->login("anonymous", 'anonymous@example.com');
47 | $ftp->cwd($path);
48 | $ftp->binary;
49 | $ftp->get($file) or (warn("$!\n"), return);
50 | $ftp->quit;
51 | } }
52 | elsif (my $ftp = $self->can_run('ftp')) { eval {
53 | # no Net::FTP, fallback to ftp.exe
54 | require FileHandle;
55 | my $fh = FileHandle->new;
56 |
57 | local $SIG{CHLD} = 'IGNORE';
58 | unless ($fh->open("|$ftp -n")) {
59 | warn "Couldn't open ftp: $!\n";
60 | chdir $dir; return;
61 | }
62 |
63 | my @dialog = split(/\n/, <<"END_FTP");
64 | open $host
65 | user anonymous anonymous\@example.com
66 | cd $path
67 | binary
68 | get $file $file
69 | quit
70 | END_FTP
71 | foreach (@dialog) { $fh->print("$_\n") }
72 | $fh->close;
73 | } }
74 | else {
75 | warn "No working 'ftp' program available!\n";
76 | chdir $dir; return;
77 | }
78 |
79 | unless (-f $file) {
80 | warn "Fetching failed: $@\n";
81 | chdir $dir; return;
82 | }
83 |
84 | return if exists $args{size} and -s $file != $args{size};
85 | system($args{run}) if exists $args{run};
86 | unlink($file) if $args{remove};
87 |
88 | print(((!exists $args{check_for} or -e $args{check_for})
89 | ? "done!" : "failed! ($!)"), "\n");
90 | chdir $dir; return !$?;
91 | }
92 |
93 | 1;
94 |
--------------------------------------------------------------------------------
/t/pdf-webkit-source.t:
--------------------------------------------------------------------------------
1 | #!perl
2 | use Test::Spec;
3 | use utf8;
4 | use strict;
5 |
6 | use File::Basename qw(dirname);
7 | use File::Spec;
8 |
9 | BEGIN { require File::Spec->catfile(dirname(__FILE__), "spec_helper.pl") }
10 |
11 | my $source;
12 |
13 | describe "PDF::WebKit::Source" => sub {
14 |
15 | describe "->is_url" => sub {
16 | it "should return true if passed a URL-like string" => sub {
17 | $source = PDF::WebKit::Source->new('http://google.com');
18 | ok($source->is_url);
19 | };
20 | it "should return false if passed a filename (non-URL)" => sub {
21 | $source = PDF::WebKit::Source->new('/dev/null');
22 | ok(!$source->is_url);
23 | };
24 | it "should return false if passed a scalar reference (HTML document)" => sub {
25 | $source = PDF::WebKit::Source->new(\'');
26 | ok(!$source->is_url);
27 | };
28 | it "should return false if passed HTML with embedded urls at the beginning of a line" => sub {
29 | $source = PDF::WebKit::Source->new(\"\nhttp://www.google.com");
30 | ok(!$source->is_url);
31 | };
32 | };
33 |
34 | describe "->is_file" => sub {
35 | it "should return true if passed a filename (non-URL-like string)" => sub {
36 | $source = PDF::WebKit::Source->new('/dev/null');
37 | ok($source->is_file);
38 | };
39 | it "should return false if passed a URL-like string" => sub {
40 | $source = PDF::WebKit::Source->new('http://google.com');
41 | ok(!$source->is_file);
42 | };
43 | it "should return false if passed a scalar reference (HTML document)" => sub {
44 | $source = PDF::WebKit::Source->new(\'');
45 | ok(!$source->is_file);
46 | };
47 | };
48 |
49 | describe "->is_html" => sub {
50 | it "should return true if passed a scalar reference (HTML document)" => sub {
51 | $source = PDF::WebKit::Source->new(\'');
52 | ok($source->is_html);
53 | };
54 | it "should return false if passed a file" => sub {
55 | $source = PDF::WebKit::Source->new('/dev/null');
56 | ok(!$source->is_html);
57 | };
58 | it "should return false if passed a URL-like string" => sub {
59 | $source = PDF::WebKit::Source->new('http://google.com');
60 | ok(!$source->is_html);
61 | };
62 | };
63 |
64 | describe "->content" => sub {
65 | it "should return the HTML if passed HTML" => sub {
66 | $source = PDF::WebKit::Source->new(\'');
67 | is($source->content, '');
68 | };
69 | it "should return the filename if passed a filename" => sub {
70 | $source = PDF::WebKit::Source->new(__FILE__);
71 | is($source->content, __FILE__);
72 | };
73 | it "should return the URL if passed a URL-like string" => sub {
74 | $source = PDF::WebKit::Source->new('http://google.com');
75 | is($source->content, 'http://google.com');
76 | };
77 | };
78 |
79 | };
80 |
81 | runtests unless caller;
82 |
--------------------------------------------------------------------------------
/t/pdf-webkit-integration.t:
--------------------------------------------------------------------------------
1 | #!perl
2 | use Test::Spec;
3 | use utf8;
4 | no strict;
5 |
6 | use File::Basename qw(dirname);
7 | use File::Spec;
8 |
9 | BEGIN { require File::Spec->catfile(dirname(__FILE__), "spec_helper.pl") }
10 |
11 | my $executable = PDF::WebKit::Configuration->configuration->wkhtmltopdf;
12 | if (not ($executable && -x $executable)) {
13 | plan skip_all => "wkhtmltopdf not available (make sure it's in your path)";
14 | }
15 |
16 | describe "PDF::WebKit" => sub {
17 |
18 | describe "->to_pdf" => sub {
19 | it "should generate a PDF of the HTML" => sub {
20 | my $pdfkit = PDF::WebKit->new(\'html', page_size => 'Letter');
21 | my $pdf = $pdfkit->to_pdf;
22 | is(substr($pdf,0,4), '%PDF'); # PDF Signature at beginning of file
23 | };
24 |
25 | it "should generate a PDF with a numerical parameter" => sub {
26 | my $pdfkit = PDF::WebKit->new(\'html', header_spacing => 1);
27 | my $pdf = $pdfkit->to_pdf;
28 | is(substr($pdf,0,4), '%PDF'); # PDF Signature at beginning of file
29 | };
30 |
31 | it "should have the stylesheet added to the head if it has one" => sub {
32 | my $pdfkit = PDF::WebKit->new(\"Hai!");
33 | my $stylesheet = File::Spec->catfile($SPEC_ROOT,'fixtures','example.css');
34 | push @{ $pdfkit->stylesheets }, $stylesheet;
35 | $pdfkit->to_pdf;
36 | my $css = do { local (@ARGV,$/) = ($stylesheet); <> };
37 | like($pdfkit->source->content, qr{});
38 | };
39 |
40 | it "should prepend style tags if the HTML doesn't have a head tag" => sub {
41 | my $pdfkit = PDF::WebKit->new(\"Hai!");
42 | my $stylesheet = File::Spec->catfile($SPEC_ROOT,'fixtures','example.css');
43 | push @{ $pdfkit->stylesheets }, $stylesheet;
44 | $pdfkit->to_pdf;
45 | my $css = do { local (@ARGV,$/) = ($stylesheet); <> };
46 | like($pdfkit->source->content, qr{});
47 | };
48 |
49 | it "should throw an error if the source is not html and stylesheets have been added" => sub {
50 | my $pdfkit = PDF::WebKit->new('http://google.com');
51 | my $stylesheet = File::Spec->catfile($SPEC_ROOT,'fixtures','example.css');
52 | push @{ $pdfkit->stylesheets }, $stylesheet;
53 | eval { $pdfkit->to_pdf };
54 | like($@, qr/stylesheet.*html/i);
55 | };
56 |
57 | };
58 |
59 | describe "->to_file" => sub {
60 | before each => sub {
61 | $file_path = File::Spec->catfile($SPEC_ROOT,'fixtures','test.pdf');
62 | unlink($file_path) if -e $file_path;
63 | };
64 | after each => sub {
65 | unlink($file_path);
66 | };
67 |
68 | it "should create a file with the PDF as content" => sub {
69 | my $pdfkit = PDF::WebKit->new(\'html', page_size => 'Letter');
70 | my $file = $pdfkit->to_file($file_path);
71 | ok( $file->isa('IO::File') );
72 | $file->read(my $buf,4) || die $!;
73 | is($buf, '%PDF'); # PDF Signature at beginning of file
74 | };
75 | };
76 |
77 | describe "security" => sub {
78 | before each => sub {
79 | $test_path = File::Spec->catfile($SPEC_ROOT,'fixtures','security-oops');
80 | unlink($test_path) if -e $test_path;
81 | };
82 | after each => sub {
83 | unlink($test_path) if -e $test_path;
84 | };
85 |
86 | it "should not allow shell injection in options" => sub {
87 | my $pdfkit = PDF::WebKit->new(\'html', header_center => "a title\"; touch $test_path #");
88 | eval { $pdfkit->to_pdf }; # wkhtmltopdf itself errors out on windows
89 | ok(! -e $test_path);
90 | };
91 | };
92 |
93 | };
94 |
95 | runtests unless caller;
96 |
97 |
--------------------------------------------------------------------------------
/t/pdf-webkit.t:
--------------------------------------------------------------------------------
1 | #!perl
2 | use Test::Spec;
3 | use utf8;
4 | no strict;
5 |
6 | use File::Basename qw(dirname);
7 | use File::Spec;
8 |
9 | BEGIN { require File::Spec->catfile(dirname(__FILE__), "spec_helper.pl") }
10 |
11 | # has to exist
12 | my $ext = $^O eq "MSWin32" ? ".bat" : "";
13 | my $wkhtmltopdf = File::Spec->catfile($SPEC_ROOT,'fixtures',"mock_wkhtmltopdf$ext");
14 |
15 | describe "PDF::WebKit" => sub {
16 |
17 | before all => sub {
18 | PDF::WebKit->configure(sub {
19 | $_->wkhtmltopdf($wkhtmltopdf);
20 | });
21 | };
22 |
23 | describe "initialization" => sub {
24 |
25 | it "should accept HTML as the source when the source is a scalar reference" => sub {
26 | my $pdfkit = PDF::WebKit->new(\'Oh Hai
');
27 | ok($pdfkit->source->is_html &&
28 | $pdfkit->source->content eq 'Oh Hai
');
29 | };
30 |
31 | it "should accept a URL as the source" => sub {
32 | my $pdfkit = PDF::WebKit->new('http://google.com');
33 | ok($pdfkit->source->is_url &&
34 | $pdfkit->source->content eq 'http://google.com');
35 | };
36 |
37 | it "should accept a File as the source" => sub {
38 | my $file_path = File::Spec->catfile($SPEC_ROOT,'fixtures','example.html');
39 | my $pdfkit = PDF::WebKit->new($file_path);
40 | ok($pdfkit->source->is_file &&
41 | $pdfkit->source->content eq $file_path);
42 | };
43 |
44 | it "should parse the options into a cmd line friendly format" => sub {
45 | my $pdfkit = PDF::WebKit->new('html', page_size => 'Letter');
46 | ok( exists $pdfkit->options->{'--page-size'} );
47 | };
48 |
49 | it "should replace any and all leading option hyphens with the standard two-hyphen dash" => sub {
50 | my $pdfkit = PDF::WebKit->new('html', '-page_size' => 'Letter');
51 | ok( exists $pdfkit->options->{'--page-size'} );
52 | };
53 |
54 | it "should provide default options" => sub {
55 | my $pdfkit = PDF::WebKit->new('Oh Hai
');
56 | my $options = $pdfkit->options;
57 | ok( exists $options->{'--margin-top'} &&
58 | exists $options->{'--margin-right'} &&
59 | exists $options->{'--margin-bottom'} &&
60 | exists $options->{'--margin-left'});
61 | };
62 |
63 | it "should default to 'UTF-8' encoding" => sub {
64 | my $pdfkit = PDF::WebKit->new('Captación');
65 | is($pdfkit->options->{'--encoding'}, 'UTF-8');
66 | };
67 |
68 | it "should not have any stylesheet by default" => sub {
69 | my $pdfkit = PDF::WebKit->new('Oh Hai
');
70 | is_deeply( $pdfkit->stylesheets, [] );
71 | };
72 |
73 | };
74 |
75 | describe "->command" => sub {
76 | it "should construct the correct command" => sub {
77 | my $pdfkit = PDF::WebKit->new(\'html', page_size => 'Letter', toc_l1_font_size => 12);
78 | my @command = $pdfkit->command;
79 | like( $command[0], qr/\Q$wkhtmltopdf/ );
80 | is( $command[index_of('--page-size',@command) + 1], 'Letter' );
81 | is( $command[index_of('--toc-l1-font-size',@command) + 1], '12' );
82 | is( $command[-3], '--quiet' );
83 | is( $command[-2], '-' ); # from stdin
84 | is( $command[-1], '-' ); # to stdout
85 | };
86 |
87 | it "will not include default options it is told to omit" => sub {
88 | PDF::WebKit->configure(sub {
89 | $_->default_options->{disable_smart_shrinking} = 'yes';
90 | });
91 | my $pdfkit = PDF::WebKit->new(\'html');
92 | my @command = $pdfkit->command;
93 | ok( index_of('--disable-smart-shrinking',@command) );
94 | isnt( $command[index_of('--disable-smart-shrinking',@command) + 1], 'yes' );
95 |
96 | $pdfkit = PDF::WebKit->new(\'html', disable_smart_shrinking => undef);
97 | @command = $pdfkit->command;
98 | is( index_of('--disable-smart-shrinking',@command), undef );
99 | };
100 |
101 | it "should accept parameters with no arguments as /yes/i" => sub {
102 | my $pdfkit = PDF::WebKit->new(\'html', no_collate => 'YeS');
103 | my @command = $pdfkit->command;
104 | like( $command[0], qr/\Q$wkhtmltopdf/ );
105 | # no extra parameter between no-collate and our boilerplate
106 | like( $command[index_of('--no-collate',@command) + 1], qr/^-/ );
107 | };
108 |
109 | it "should encapsulate string arguments in quotes" => sub {
110 | my $pdfkit = PDF::WebKit->new(\'html', header_center => "foo [page]");
111 | my @command = $pdfkit->command;
112 | is( $command[ index_of('--header-center',@command) + 1 ], 'foo [page]' );
113 | };
114 |
115 | it "reads the source from stdin if it is html" => sub {
116 | my $pdfkit = PDF::WebKit->new(\'html');
117 | my @command = $pdfkit->command;
118 | is_deeply( [@command[-2,-1]], ['-', '-'] );
119 | };
120 |
121 | it "specifies the URL to the source if it is a URL" => sub {
122 | my $pdfkit = PDF::WebKit->new('http://google.com');
123 | my @command = $pdfkit->command;
124 | is_deeply( [@command[-2,-1]], ['http://google.com', '-'] );
125 | };
126 |
127 | it "should specify the path to the source if it is a file" => sub {
128 | my $file_path = File::Spec->catfile($SPEC_ROOT,'fixtures','example.html');
129 | my $pdfkit = PDF::WebKit->new($file_path);
130 | my @command = $pdfkit->command;
131 | is_deeply( [@command[-2,-1]], [$file_path, '-'] );
132 | };
133 |
134 | it "should specify the path for the output if a path is given" => sub {
135 | my $file_path = "/path/to/output.pdf";
136 | my $pdfkit = PDF::WebKit->new(\"html");
137 | my @command = $pdfkit->command($file_path);
138 | is($command[-1], $file_path);
139 | };
140 |
141 | SKIP: {
142 | skip "XML::LibXML is unavailable", 2
143 | unless eval { require XML::LibXML };
144 |
145 | it "should detect special pdf-webkit meta tags" => sub {
146 | my $body = q{
147 |
148 |
149 |
150 |
151 |
152 |
153 | };
154 | my $pdfkit = PDF::WebKit->new(\$body);
155 | my @command = $pdfkit->command;
156 | is( $command[ index_of('--page-size',@command) + 1 ], 'Legal' );
157 | is( $command[ index_of('--orientation',@command) + 1 ], 'Landscape' );
158 | };
159 |
160 | it "should normalize options before combining, so e.g. page-size can override default page_size" => sub {
161 | # This test can pass even if the behavior is broken.
162 | # I'm not sure how to fix it without converting PDF::WebKit to
163 | # use an ordered hash. The hashing order created by this data
164 | # set evokes the bug in perl 5.8.9, at least.
165 | my $body = q{
166 |
167 |
168 |
169 |
170 |
171 |
172 |
173 |
174 |
175 | };
176 | my $pdfkit = PDF::WebKit->new(\$body);
177 | my @command = $pdfkit->command;
178 | is( scalar(grep { /page.*size/ } @command), 1 );
179 | is( scalar(grep { /margin.*top/ } @command), 1 );
180 | is( scalar(grep { /margin.*bottom/ } @command), 1 );
181 | is( $command[ index_of('--page-size',@command) + 1 ], 'Legal' );
182 | is( $command[ index_of('--margin-top',@command) + 1 ], '0' );
183 | is( $command[ index_of('--margin-bottom',@command) + 1 ], '0' );
184 | };
185 | }
186 | };
187 |
188 | };
189 |
190 | runtests unless caller;
191 |
192 |
--------------------------------------------------------------------------------
/lib/PDF/WebKit.pm:
--------------------------------------------------------------------------------
1 | package PDF::WebKit;
2 | use 5.008008;
3 | use strict;
4 | use warnings;
5 | use Carp ();
6 | use IO::File ();
7 | use IPC::Run3 'run3';
8 |
9 | use PDF::WebKit::Configuration;
10 | use PDF::WebKit::Source;
11 |
12 | our $VERSION = '1.2';
13 |
14 | use Moo;
15 | use namespace::clean;
16 |
17 | has source => ( is => 'rw' );
18 | has stylesheets => ( is => 'rw' );
19 | has options => ( is => 'ro', writer => '_set_options' );
20 |
21 | around 'BUILDARGS' => sub {
22 | my $orig = shift;
23 | my $class = shift;
24 |
25 | if (@_ % 2 == 0) {
26 | Carp::croak "Usage: ${class}->new(\$url_file_or_html,%options)";
27 | }
28 |
29 | my $url_file_or_html = shift;
30 | my $options = { @_ };
31 | return $class->$orig({ source => $url_file_or_html, options => $options });
32 | };
33 |
34 | sub BUILD {
35 | my ($self,$args) = @_;
36 |
37 | $self->source( PDF::WebKit::Source->new($args->{source}) );
38 | $self->stylesheets( [] );
39 | $self->_set_options({
40 | $self->_normalize_options(%{ $self->configuration->default_options }),
41 | $self->_normalize_options(%{ $args->{options} }),
42 | $self->_normalize_options($self->_find_options_in_meta),
43 | });
44 |
45 | if (not -x $self->configuration->wkhtmltopdf) {
46 | my $msg = "No wkhtmltopdf executable found\n";
47 | $msg .= ">> Please install wkhtmltopdf - https://github.com/jdpace/PDFKit/wiki/Installing-WKHTMLTOPDF";
48 | die $msg;
49 | }
50 | }
51 |
52 | sub configuration {
53 | PDF::WebKit::Configuration->configuration
54 | }
55 |
56 | sub configure {
57 | my $class = shift;
58 | $class->configuration->configure(@_);
59 | }
60 |
61 | sub command {
62 | my $self = shift;
63 | my $path = shift;
64 | my @args = ( $self->_executable, $self->_prepare_options, '--quiet' );
65 |
66 | if ($self->source->is_html) {
67 | push @args, '-'; # Get HTML from stdin
68 | }
69 | else {
70 | push @args, $self->source->content;
71 | }
72 |
73 | push @args, $path || '-'; # write to file or stdout
74 |
75 | return grep { defined($_) } @args;
76 | }
77 |
78 | sub _executable {
79 | my $self = shift;
80 | my $default = $self->configuration->wkhtmltopdf;
81 | return $default if $default !~ /^\//; # it's not a path, so nothing we can do
82 | return $default if -e $default;
83 | return (split(/\//, $default))[-1];
84 | }
85 |
86 | sub to_pdf {
87 | my $self = shift;
88 | my $path = shift;
89 |
90 | $self->_append_stylesheets;
91 | my @args = $self->command($path);
92 |
93 | my $input = $self->source->is_html ? $self->source->content : undef;
94 | my $output;
95 | my $temp_fn;
96 | if (!defined $input and @args > 3 and -f $args[-2] and my $enc = $self->{options}{"--encoding"}) {
97 | # interestingly, wkhtmltopdf 0.12.4 does not know about --encoding
98 | my $meta = '';
99 | use File::Temp;
100 | (undef, $temp_fn) = File::Temp::tempfile ("tmpwkXXXXX", SUFFIX => ".html", OPEN => 0, UNLINK => 1);
101 | if (open my $fhi, "<:encoding($enc)", $args[-2] and
102 | open my $fho, ">:encoding(utf-8)", $temp_fn) {
103 | local $/;
104 | my $in = <$fhi>;
105 | my ($head) = $in =~ m{(.*?)}is;
106 | if (!$head) {
107 | $in =~ s{(?=)}{$meta}i;
108 | }
109 | elsif ($head !~ m{charset=}) {
110 | $in =~ s{(?<=)}{$meta}i;
111 | }
112 | print $fho $in;
113 | close $fhi;
114 | close $fho;
115 | $args[-2] = $temp_fn;
116 | }
117 | }
118 |
119 | my %opt = map +( "binmode_std$_" => ":raw" ), "in", "out", "err";
120 | run3 \@args, \$input, \$output, \my $err, \%opt;
121 |
122 | $temp_fn && -f $temp_fn and unlink $temp_fn; # UNLINK not effective on OPEN => 0
123 |
124 | if ($path) {
125 | $output = do { local (@ARGV,$/) = ($path); <> };
126 | }
127 |
128 | if (not (defined($output) && length($output))) {
129 | Carp::croak "command failed: $args[0]";
130 | }
131 | return $output;
132 | }
133 |
134 | sub to_file {
135 | my $self = shift;
136 | my $path = shift;
137 | $self->to_pdf($path);
138 | my $FH = IO::File->new($path,"<")
139 | || Carp::croak "can't open '$path': $!";
140 | $FH->binmode();
141 | return $FH;
142 | }
143 |
144 | sub _find_options_in_meta {
145 | my ($self) = @_;
146 | return () if $self->source->is_url;
147 | # if we can't parse for whatever reason, keep calm and carry on.
148 | my @result = eval { $self->_pdf_webkit_meta_tags };
149 | return $@ ? () : @result;
150 | }
151 |
152 | sub _pdf_webkit_meta_tags {
153 | my ($self) = @_;
154 | return () unless eval { require XML::LibXML };
155 | my $source = $self->source;
156 |
157 | my $prefix = $self->configuration->meta_tag_prefix;
158 |
159 | # these options do not work at the constructor level in XML::LibXML 1.70, so pass
160 | # them through to the parser.
161 | my %options = (
162 | recover => 2,
163 | suppress_errors => 1,
164 | suppress_warnings => 1,
165 | no_network => 1,
166 | );
167 |
168 | my $parser = XML::LibXML->new();
169 | my $enc = $self->{options}{encoding};
170 | if ($enc) {
171 | $options{encoding} = $enc;
172 | }
173 | my $doc = $source->is_html ? $parser->parse_html_string($source->content,\%options)
174 | : $source->is_file ? $parser->parse_html_file($source->string,\%options)
175 | : return ();
176 |
177 | my %meta;
178 | for my $node ($doc->findnodes('html/head/meta')) {
179 | my $name = $node->getAttribute('name');
180 | next unless ($name && ($name =~ s{^\Q$prefix}{}s));
181 | $meta{$name} = $node->getAttribute('content');
182 | }
183 |
184 | return %meta;
185 | }
186 |
187 | sub _style_tag_for {
188 | my ($self,$stylesheet) = @_;
189 | my $styles = do { local (@ARGV,$/) = ($stylesheet); <> };
190 | return "";
191 | }
192 |
193 | sub _append_stylesheets {
194 | my $self = shift;
195 | if (@{ $self->stylesheets } && !$self->source->is_html) {
196 | Carp::croak "stylesheets may only be added to an HTML source";
197 | }
198 | return unless $self->source->is_html;
199 |
200 | my $styles = join "", map { $self->_style_tag_for($_) } @{$self->stylesheets};
201 | return unless length($styles) > 0;
202 |
203 | # can't modify in-place, because the source might be a reference to a
204 | # read-only constant string literal
205 | my $html = $self->source->content;
206 | if (not ($html =~ s{(?=)}{$styles})) {
207 | $html = $styles . $html;
208 | }
209 | $self->source->string(\$html);
210 | }
211 |
212 | sub _prepare_options {
213 | my ($self) = @_;
214 | my $options = $self->options;
215 | my @args;
216 | while (my ($name,$val) = each %$options) {
217 | next unless defined($val) && length($val);
218 | if (lc($val) eq 'yes') {
219 | push @args, $name;
220 | }
221 | else {
222 | push @args, $name, $val;
223 | }
224 | }
225 | return @args;
226 | }
227 |
228 | sub _normalize_options {
229 | my $self = shift;
230 | my %orig_options = @_;
231 | my %normalized_options;
232 | while (my ($key,$val) = each %orig_options) {
233 | my $normalized_key = $self->_normalize_arg($key);
234 | $normalized_options{$normalized_key} = $val;
235 | }
236 | return %normalized_options;
237 | }
238 |
239 | sub _normalize_arg {
240 | my ($self,$arg) = @_;
241 | $arg =~ lc($arg);
242 | $arg =~ s{[^a-z0-9]}{-}g;
243 | $arg =~ s{^-*}{--};
244 | return $arg;
245 | }
246 |
247 | 1;
248 |
249 | =head1 NAME
250 |
251 | PDF::WebKit - Use WebKit to Generate PDFs from HTML (via wkhtmltopdf)
252 |
253 | =head1 SYNOPSIS
254 |
255 | use PDF::WebKit;
256 |
257 | # PDF::WebKit->new takes the HTML and any options for wkhtmltopdf
258 | # run `wkhtmltopdf --extended-help` for a full list of options
259 | my $kit = PDF::WebKit->new(\$html, page_size => 'Letter');
260 | push @{ $kit->stylesheets }, "/path/to/css/file";
261 |
262 | # Get an inline PDF
263 | my $pdf = $kit->to_pdf;
264 |
265 | # save the PDF to a file
266 | my $file = $kit->to_file('/path/to/save/pdf');
267 |
268 | # PDF::WebKit can optionally accept a URL or a File
269 | # Stylesheets cannot be added when source is provided as a URL or File.
270 | my $kit = PDF::WebKit->new('http://google.com');
271 | my $kit = PDF::WebKit->new('/path/to/html');
272 |
273 | # Add any kind of option through meta tags
274 | my $kit = PDF::WebKit->new(\' to
279 | convert HTML documents into PDFs. It is a port of the elegant
280 | L Ruby library.
281 |
282 | wkhtmltopdf generates beautiful PDFs by leveraging the rendering power
283 | of Qt's WebKit browser engine (used by both Apple Safari and Google
284 | Chrome browsers).
285 |
286 | =head2 Configuration
287 |
288 | Configuration of PDF::WebKit is configured globally by calling the
289 | C<< PDF::WebKit->configure >> class method:
290 |
291 | PDF::WebKit->configure(sub {
292 | # default `which wkhtmltopdf`
293 | $_->wkhtmltopdf('/path/to/wkhtmltopdf');
294 |
295 | # default 'pdf-webkit-'
296 | $_->meta_tag_prefix('my-prefix-');
297 |
298 | $_->default_options->{'--orientation'} = 'Portrait';
299 | });
300 |
301 | See the L method for the standard default options.
302 |
303 | =head2 Constructor
304 |
305 | =over 4
306 |
307 | =item new($SOURCE_URL,%OPTIONS)
308 |
309 | =item new($SOURCE_FILENAME,%OPTIONS)
310 |
311 | =item new(\$SOURCE_HTML,%OPTIONS)
312 |
313 | Creates and returns a new instance. If the first parameter looks like a
314 | URL, it is treated as a URL and handed off to wkhtmltopdf verbatim. If
315 | it is is a reference to a scalar, it is an HTML document body.
316 | Otherwise, the parameter is interpreted as a filename.
317 |
318 | The %OPTIONS hash is a list of name/value pairs for command-line
319 | options to wkhtmltopdf. These options can augment or override the
320 | default options. For options with no associated value, pass "YES" (case
321 | insensitive) as the value, e.g. C "YES">.
322 |
323 | The default options are:
324 |
325 | --page-size Letter
326 | --margin-top 0.75in
327 | --margin_right 0.75in
328 | --margin_bottom 0.75in
329 | --margin_left 0.75in
330 | --encoding UTF-8
331 |
332 | =back
333 |
334 | =head2 Methods
335 |
336 | =over 4
337 |
338 | =item command
339 |
340 | Returns the list of command-line arguments that would be used to execute
341 | wkhtmltopdf.
342 |
343 | =item to_pdf
344 |
345 | Processes the source material and returns a PDF as a string.
346 |
347 | =item to_file($PATH)
348 |
349 | Processes the source material and creates a PDF at C<$PATH>. Returns a
350 | filehandle opened on C<$PATH>.
351 |
352 | =back
353 |
354 | =head1 SEE ALSO
355 |
356 | L,
357 | L,
358 | L
359 | (a lower-level wrapper for wkhtmltopdf).
360 |
361 | =head1 AUTHOR
362 |
363 | Philip Garrett
364 |
365 | =head1 CONTRIBUTORS
366 |
367 | Christian Walde
368 |
369 | =head1 CONTRIBUTING
370 |
371 | If you'd like to contribute, just fork my repository on Github, commit
372 | your changes and send me a pull request.
373 |
374 | http://github.com/kingpong/perl-PDF-WebKit
375 |
376 | =head1 ACKNOWLEDGMENTS
377 |
378 | This code is nearly a line-by-line port of Jared Pace's PDFKit.
379 | https://github.com/jdpace/PDFKit
380 |
381 | =head1 COPYRIGHT & LICENSE
382 |
383 | Copyright (c) 2011 by Informatics Corporation of America.
384 |
385 | This library is free software; you can redistribute it and/or modify
386 | it under the same terms as Perl itself, either Perl version 5.8.8 or,
387 | at your option, any later version of Perl 5 you may have available.
388 |
389 | =cut
390 |
--------------------------------------------------------------------------------
/inc/Module/Install/Makefile.pm:
--------------------------------------------------------------------------------
1 | #line 1
2 | package Module::Install::Makefile;
3 |
4 | use strict 'vars';
5 | use ExtUtils::MakeMaker ();
6 | use Module::Install::Base ();
7 | use Fcntl qw/:flock :seek/;
8 |
9 | use vars qw{$VERSION @ISA $ISCORE};
10 | BEGIN {
11 | $VERSION = '1.01';
12 | @ISA = 'Module::Install::Base';
13 | $ISCORE = 1;
14 | }
15 |
16 | sub Makefile { $_[0] }
17 |
18 | my %seen = ();
19 |
20 | sub prompt {
21 | shift;
22 |
23 | # Infinite loop protection
24 | my @c = caller();
25 | if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
26 | die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
27 | }
28 |
29 | # In automated testing or non-interactive session, always use defaults
30 | if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) {
31 | local $ENV{PERL_MM_USE_DEFAULT} = 1;
32 | goto &ExtUtils::MakeMaker::prompt;
33 | } else {
34 | goto &ExtUtils::MakeMaker::prompt;
35 | }
36 | }
37 |
38 | # Store a cleaned up version of the MakeMaker version,
39 | # since we need to behave differently in a variety of
40 | # ways based on the MM version.
41 | my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
42 |
43 | # If we are passed a param, do a "newer than" comparison.
44 | # Otherwise, just return the MakeMaker version.
45 | sub makemaker {
46 | ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
47 | }
48 |
49 | # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified
50 | # as we only need to know here whether the attribute is an array
51 | # or a hash or something else (which may or may not be appendable).
52 | my %makemaker_argtype = (
53 | C => 'ARRAY',
54 | CONFIG => 'ARRAY',
55 | # CONFIGURE => 'CODE', # ignore
56 | DIR => 'ARRAY',
57 | DL_FUNCS => 'HASH',
58 | DL_VARS => 'ARRAY',
59 | EXCLUDE_EXT => 'ARRAY',
60 | EXE_FILES => 'ARRAY',
61 | FUNCLIST => 'ARRAY',
62 | H => 'ARRAY',
63 | IMPORTS => 'HASH',
64 | INCLUDE_EXT => 'ARRAY',
65 | LIBS => 'ARRAY', # ignore ''
66 | MAN1PODS => 'HASH',
67 | MAN3PODS => 'HASH',
68 | META_ADD => 'HASH',
69 | META_MERGE => 'HASH',
70 | PL_FILES => 'HASH',
71 | PM => 'HASH',
72 | PMLIBDIRS => 'ARRAY',
73 | PMLIBPARENTDIRS => 'ARRAY',
74 | PREREQ_PM => 'HASH',
75 | CONFIGURE_REQUIRES => 'HASH',
76 | SKIP => 'ARRAY',
77 | TYPEMAPS => 'ARRAY',
78 | XS => 'HASH',
79 | # VERSION => ['version',''], # ignore
80 | # _KEEP_AFTER_FLUSH => '',
81 |
82 | clean => 'HASH',
83 | depend => 'HASH',
84 | dist => 'HASH',
85 | dynamic_lib=> 'HASH',
86 | linkext => 'HASH',
87 | macro => 'HASH',
88 | postamble => 'HASH',
89 | realclean => 'HASH',
90 | test => 'HASH',
91 | tool_autosplit => 'HASH',
92 |
93 | # special cases where you can use makemaker_append
94 | CCFLAGS => 'APPENDABLE',
95 | DEFINE => 'APPENDABLE',
96 | INC => 'APPENDABLE',
97 | LDDLFLAGS => 'APPENDABLE',
98 | LDFROM => 'APPENDABLE',
99 | );
100 |
101 | sub makemaker_args {
102 | my ($self, %new_args) = @_;
103 | my $args = ( $self->{makemaker_args} ||= {} );
104 | foreach my $key (keys %new_args) {
105 | if ($makemaker_argtype{$key}) {
106 | if ($makemaker_argtype{$key} eq 'ARRAY') {
107 | $args->{$key} = [] unless defined $args->{$key};
108 | unless (ref $args->{$key} eq 'ARRAY') {
109 | $args->{$key} = [$args->{$key}]
110 | }
111 | push @{$args->{$key}},
112 | ref $new_args{$key} eq 'ARRAY'
113 | ? @{$new_args{$key}}
114 | : $new_args{$key};
115 | }
116 | elsif ($makemaker_argtype{$key} eq 'HASH') {
117 | $args->{$key} = {} unless defined $args->{$key};
118 | foreach my $skey (keys %{ $new_args{$key} }) {
119 | $args->{$key}{$skey} = $new_args{$key}{$skey};
120 | }
121 | }
122 | elsif ($makemaker_argtype{$key} eq 'APPENDABLE') {
123 | $self->makemaker_append($key => $new_args{$key});
124 | }
125 | }
126 | else {
127 | if (defined $args->{$key}) {
128 | warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n};
129 | }
130 | $args->{$key} = $new_args{$key};
131 | }
132 | }
133 | return $args;
134 | }
135 |
136 | # For mm args that take multiple space-seperated args,
137 | # append an argument to the current list.
138 | sub makemaker_append {
139 | my $self = shift;
140 | my $name = shift;
141 | my $args = $self->makemaker_args;
142 | $args->{$name} = defined $args->{$name}
143 | ? join( ' ', $args->{$name}, @_ )
144 | : join( ' ', @_ );
145 | }
146 |
147 | sub build_subdirs {
148 | my $self = shift;
149 | my $subdirs = $self->makemaker_args->{DIR} ||= [];
150 | for my $subdir (@_) {
151 | push @$subdirs, $subdir;
152 | }
153 | }
154 |
155 | sub clean_files {
156 | my $self = shift;
157 | my $clean = $self->makemaker_args->{clean} ||= {};
158 | %$clean = (
159 | %$clean,
160 | FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
161 | );
162 | }
163 |
164 | sub realclean_files {
165 | my $self = shift;
166 | my $realclean = $self->makemaker_args->{realclean} ||= {};
167 | %$realclean = (
168 | %$realclean,
169 | FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
170 | );
171 | }
172 |
173 | sub libs {
174 | my $self = shift;
175 | my $libs = ref $_[0] ? shift : [ shift ];
176 | $self->makemaker_args( LIBS => $libs );
177 | }
178 |
179 | sub inc {
180 | my $self = shift;
181 | $self->makemaker_args( INC => shift );
182 | }
183 |
184 | sub _wanted_t {
185 | }
186 |
187 | sub tests_recursive {
188 | my $self = shift;
189 | my $dir = shift || 't';
190 | unless ( -d $dir ) {
191 | die "tests_recursive dir '$dir' does not exist";
192 | }
193 | my %tests = map { $_ => 1 } split / /, ($self->tests || '');
194 | require File::Find;
195 | File::Find::find(
196 | sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 },
197 | $dir
198 | );
199 | $self->tests( join ' ', sort keys %tests );
200 | }
201 |
202 | sub write {
203 | my $self = shift;
204 | die "&Makefile->write() takes no arguments\n" if @_;
205 |
206 | # Check the current Perl version
207 | my $perl_version = $self->perl_version;
208 | if ( $perl_version ) {
209 | eval "use $perl_version; 1"
210 | or die "ERROR: perl: Version $] is installed, "
211 | . "but we need version >= $perl_version";
212 | }
213 |
214 | # Make sure we have a new enough MakeMaker
215 | require ExtUtils::MakeMaker;
216 |
217 | if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
218 | # MakeMaker can complain about module versions that include
219 | # an underscore, even though its own version may contain one!
220 | # Hence the funny regexp to get rid of it. See RT #35800
221 | # for details.
222 | my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
223 | $self->build_requires( 'ExtUtils::MakeMaker' => $v );
224 | $self->configure_requires( 'ExtUtils::MakeMaker' => $v );
225 | } else {
226 | # Allow legacy-compatibility with 5.005 by depending on the
227 | # most recent EU:MM that supported 5.005.
228 | $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
229 | $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
230 | }
231 |
232 | # Generate the MakeMaker params
233 | my $args = $self->makemaker_args;
234 | $args->{DISTNAME} = $self->name;
235 | $args->{NAME} = $self->module_name || $self->name;
236 | $args->{NAME} =~ s/-/::/g;
237 | $args->{VERSION} = $self->version or die <<'EOT';
238 | ERROR: Can't determine distribution version. Please specify it
239 | explicitly via 'version' in Makefile.PL, or set a valid $VERSION
240 | in a module, and provide its file path via 'version_from' (or
241 | 'all_from' if you prefer) in Makefile.PL.
242 | EOT
243 |
244 | $DB::single = 1;
245 | if ( $self->tests ) {
246 | my @tests = split ' ', $self->tests;
247 | my %seen;
248 | $args->{test} = {
249 | TESTS => (join ' ', grep {!$seen{$_}++} @tests),
250 | };
251 | } elsif ( $Module::Install::ExtraTests::use_extratests ) {
252 | # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness.
253 | # So, just ignore our xt tests here.
254 | } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
255 | $args->{test} = {
256 | TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
257 | };
258 | }
259 | if ( $] >= 5.005 ) {
260 | $args->{ABSTRACT} = $self->abstract;
261 | $args->{AUTHOR} = join ', ', @{$self->author || []};
262 | }
263 | if ( $self->makemaker(6.10) ) {
264 | $args->{NO_META} = 1;
265 | #$args->{NO_MYMETA} = 1;
266 | }
267 | if ( $self->makemaker(6.17) and $self->sign ) {
268 | $args->{SIGN} = 1;
269 | }
270 | unless ( $self->is_admin ) {
271 | delete $args->{SIGN};
272 | }
273 | if ( $self->makemaker(6.31) and $self->license ) {
274 | $args->{LICENSE} = $self->license;
275 | }
276 |
277 | my $prereq = ($args->{PREREQ_PM} ||= {});
278 | %$prereq = ( %$prereq,
279 | map { @$_ } # flatten [module => version]
280 | map { @$_ }
281 | grep $_,
282 | ($self->requires)
283 | );
284 |
285 | # Remove any reference to perl, PREREQ_PM doesn't support it
286 | delete $args->{PREREQ_PM}->{perl};
287 |
288 | # Merge both kinds of requires into BUILD_REQUIRES
289 | my $build_prereq = ($args->{BUILD_REQUIRES} ||= {});
290 | %$build_prereq = ( %$build_prereq,
291 | map { @$_ } # flatten [module => version]
292 | map { @$_ }
293 | grep $_,
294 | ($self->configure_requires, $self->build_requires)
295 | );
296 |
297 | # Remove any reference to perl, BUILD_REQUIRES doesn't support it
298 | delete $args->{BUILD_REQUIRES}->{perl};
299 |
300 | # Delete bundled dists from prereq_pm, add it to Makefile DIR
301 | my $subdirs = ($args->{DIR} || []);
302 | if ($self->bundles) {
303 | my %processed;
304 | foreach my $bundle (@{ $self->bundles }) {
305 | my ($mod_name, $dist_dir) = @$bundle;
306 | delete $prereq->{$mod_name};
307 | $dist_dir = File::Basename::basename($dist_dir); # dir for building this module
308 | if (not exists $processed{$dist_dir}) {
309 | if (-d $dist_dir) {
310 | # List as sub-directory to be processed by make
311 | push @$subdirs, $dist_dir;
312 | }
313 | # Else do nothing: the module is already present on the system
314 | $processed{$dist_dir} = undef;
315 | }
316 | }
317 | }
318 |
319 | unless ( $self->makemaker('6.55_03') ) {
320 | %$prereq = (%$prereq,%$build_prereq);
321 | delete $args->{BUILD_REQUIRES};
322 | }
323 |
324 | if ( my $perl_version = $self->perl_version ) {
325 | eval "use $perl_version; 1"
326 | or die "ERROR: perl: Version $] is installed, "
327 | . "but we need version >= $perl_version";
328 |
329 | if ( $self->makemaker(6.48) ) {
330 | $args->{MIN_PERL_VERSION} = $perl_version;
331 | }
332 | }
333 |
334 | if ($self->installdirs) {
335 | warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS};
336 | $args->{INSTALLDIRS} = $self->installdirs;
337 | }
338 |
339 | my %args = map {
340 | ( $_ => $args->{$_} ) } grep {defined($args->{$_} )
341 | } keys %$args;
342 |
343 | my $user_preop = delete $args{dist}->{PREOP};
344 | if ( my $preop = $self->admin->preop($user_preop) ) {
345 | foreach my $key ( keys %$preop ) {
346 | $args{dist}->{$key} = $preop->{$key};
347 | }
348 | }
349 |
350 | my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
351 | $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
352 | }
353 |
354 | sub fix_up_makefile {
355 | my $self = shift;
356 | my $makefile_name = shift;
357 | my $top_class = ref($self->_top) || '';
358 | my $top_version = $self->_top->VERSION || '';
359 |
360 | my $preamble = $self->preamble
361 | ? "# Preamble by $top_class $top_version\n"
362 | . $self->preamble
363 | : '';
364 | my $postamble = "# Postamble by $top_class $top_version\n"
365 | . ($self->postamble || '');
366 |
367 | local *MAKEFILE;
368 | open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
369 | eval { flock MAKEFILE, LOCK_EX };
370 | my $makefile = do { local $/; };
371 |
372 | $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
373 | $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
374 | $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
375 | $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
376 | $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
377 |
378 | # Module::Install will never be used to build the Core Perl
379 | # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
380 | # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
381 | $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
382 | #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
383 |
384 | # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
385 | $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
386 |
387 | # XXX - This is currently unused; not sure if it breaks other MM-users
388 | # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
389 |
390 | seek MAKEFILE, 0, SEEK_SET;
391 | truncate MAKEFILE, 0;
392 | print MAKEFILE "$preamble$makefile$postamble" or die $!;
393 | close MAKEFILE or die $!;
394 |
395 | 1;
396 | }
397 |
398 | sub preamble {
399 | my ($self, $text) = @_;
400 | $self->{preamble} = $text . $self->{preamble} if defined $text;
401 | $self->{preamble};
402 | }
403 |
404 | sub postamble {
405 | my ($self, $text) = @_;
406 | $self->{postamble} ||= $self->admin->postamble;
407 | $self->{postamble} .= $text if defined $text;
408 | $self->{postamble}
409 | }
410 |
411 | 1;
412 |
413 | __END__
414 |
415 | #line 541
416 |
--------------------------------------------------------------------------------
/inc/Module/Install.pm:
--------------------------------------------------------------------------------
1 | #line 1
2 | package Module::Install;
3 |
4 | # For any maintainers:
5 | # The load order for Module::Install is a bit magic.
6 | # It goes something like this...
7 | #
8 | # IF ( host has Module::Install installed, creating author mode ) {
9 | # 1. Makefile.PL calls "use inc::Module::Install"
10 | # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
11 | # 3. The installed version of inc::Module::Install loads
12 | # 4. inc::Module::Install calls "require Module::Install"
13 | # 5. The ./inc/ version of Module::Install loads
14 | # } ELSE {
15 | # 1. Makefile.PL calls "use inc::Module::Install"
16 | # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
17 | # 3. The ./inc/ version of Module::Install loads
18 | # }
19 |
20 | use 5.005;
21 | use strict 'vars';
22 | use Cwd ();
23 | use File::Find ();
24 | use File::Path ();
25 |
26 | use vars qw{$VERSION $MAIN};
27 | BEGIN {
28 | # All Module::Install core packages now require synchronised versions.
29 | # This will be used to ensure we don't accidentally load old or
30 | # different versions of modules.
31 | # This is not enforced yet, but will be some time in the next few
32 | # releases once we can make sure it won't clash with custom
33 | # Module::Install extensions.
34 | $VERSION = '1.01';
35 |
36 | # Storage for the pseudo-singleton
37 | $MAIN = undef;
38 |
39 | *inc::Module::Install::VERSION = *VERSION;
40 | @inc::Module::Install::ISA = __PACKAGE__;
41 |
42 | }
43 |
44 | sub import {
45 | my $class = shift;
46 | my $self = $class->new(@_);
47 | my $who = $self->_caller;
48 |
49 | #-------------------------------------------------------------
50 | # all of the following checks should be included in import(),
51 | # to allow "eval 'require Module::Install; 1' to test
52 | # installation of Module::Install. (RT #51267)
53 | #-------------------------------------------------------------
54 |
55 | # Whether or not inc::Module::Install is actually loaded, the
56 | # $INC{inc/Module/Install.pm} is what will still get set as long as
57 | # the caller loaded module this in the documented manner.
58 | # If not set, the caller may NOT have loaded the bundled version, and thus
59 | # they may not have a MI version that works with the Makefile.PL. This would
60 | # result in false errors or unexpected behaviour. And we don't want that.
61 | my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
62 | unless ( $INC{$file} ) { die <<"END_DIE" }
63 |
64 | Please invoke ${\__PACKAGE__} with:
65 |
66 | use inc::${\__PACKAGE__};
67 |
68 | not:
69 |
70 | use ${\__PACKAGE__};
71 |
72 | END_DIE
73 |
74 | # This reportedly fixes a rare Win32 UTC file time issue, but
75 | # as this is a non-cross-platform XS module not in the core,
76 | # we shouldn't really depend on it. See RT #24194 for detail.
77 | # (Also, this module only supports Perl 5.6 and above).
78 | eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
79 |
80 | # If the script that is loading Module::Install is from the future,
81 | # then make will detect this and cause it to re-run over and over
82 | # again. This is bad. Rather than taking action to touch it (which
83 | # is unreliable on some platforms and requires write permissions)
84 | # for now we should catch this and refuse to run.
85 | if ( -f $0 ) {
86 | my $s = (stat($0))[9];
87 |
88 | # If the modification time is only slightly in the future,
89 | # sleep briefly to remove the problem.
90 | my $a = $s - time;
91 | if ( $a > 0 and $a < 5 ) { sleep 5 }
92 |
93 | # Too far in the future, throw an error.
94 | my $t = time;
95 | if ( $s > $t ) { die <<"END_DIE" }
96 |
97 | Your installer $0 has a modification time in the future ($s > $t).
98 |
99 | This is known to create infinite loops in make.
100 |
101 | Please correct this, then run $0 again.
102 |
103 | END_DIE
104 | }
105 |
106 |
107 | # Build.PL was formerly supported, but no longer is due to excessive
108 | # difficulty in implementing every single feature twice.
109 | if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
110 |
111 | Module::Install no longer supports Build.PL.
112 |
113 | It was impossible to maintain duel backends, and has been deprecated.
114 |
115 | Please remove all Build.PL files and only use the Makefile.PL installer.
116 |
117 | END_DIE
118 |
119 | #-------------------------------------------------------------
120 |
121 | # To save some more typing in Module::Install installers, every...
122 | # use inc::Module::Install
123 | # ...also acts as an implicit use strict.
124 | $^H |= strict::bits(qw(refs subs vars));
125 |
126 | #-------------------------------------------------------------
127 |
128 | unless ( -f $self->{file} ) {
129 | foreach my $key (keys %INC) {
130 | delete $INC{$key} if $key =~ /Module\/Install/;
131 | }
132 |
133 | local $^W;
134 | require "$self->{path}/$self->{dispatch}.pm";
135 | File::Path::mkpath("$self->{prefix}/$self->{author}");
136 | $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
137 | $self->{admin}->init;
138 | @_ = ($class, _self => $self);
139 | goto &{"$self->{name}::import"};
140 | }
141 |
142 | local $^W;
143 | *{"${who}::AUTOLOAD"} = $self->autoload;
144 | $self->preload;
145 |
146 | # Unregister loader and worker packages so subdirs can use them again
147 | delete $INC{'inc/Module/Install.pm'};
148 | delete $INC{'Module/Install.pm'};
149 |
150 | # Save to the singleton
151 | $MAIN = $self;
152 |
153 | return 1;
154 | }
155 |
156 | sub autoload {
157 | my $self = shift;
158 | my $who = $self->_caller;
159 | my $cwd = Cwd::cwd();
160 | my $sym = "${who}::AUTOLOAD";
161 | $sym->{$cwd} = sub {
162 | my $pwd = Cwd::cwd();
163 | if ( my $code = $sym->{$pwd} ) {
164 | # Delegate back to parent dirs
165 | goto &$code unless $cwd eq $pwd;
166 | }
167 | unless ($$sym =~ s/([^:]+)$//) {
168 | # XXX: it looks like we can't retrieve the missing function
169 | # via $$sym (usually $main::AUTOLOAD) in this case.
170 | # I'm still wondering if we should slurp Makefile.PL to
171 | # get some context or not ...
172 | my ($package, $file, $line) = caller;
173 | die <<"EOT";
174 | Unknown function is found at $file line $line.
175 | Execution of $file aborted due to runtime errors.
176 |
177 | If you're a contributor to a project, you may need to install
178 | some Module::Install extensions from CPAN (or other repository).
179 | If you're a user of a module, please contact the author.
180 | EOT
181 | }
182 | my $method = $1;
183 | if ( uc($method) eq $method ) {
184 | # Do nothing
185 | return;
186 | } elsif ( $method =~ /^_/ and $self->can($method) ) {
187 | # Dispatch to the root M:I class
188 | return $self->$method(@_);
189 | }
190 |
191 | # Dispatch to the appropriate plugin
192 | unshift @_, ( $self, $1 );
193 | goto &{$self->can('call')};
194 | };
195 | }
196 |
197 | sub preload {
198 | my $self = shift;
199 | unless ( $self->{extensions} ) {
200 | $self->load_extensions(
201 | "$self->{prefix}/$self->{path}", $self
202 | );
203 | }
204 |
205 | my @exts = @{$self->{extensions}};
206 | unless ( @exts ) {
207 | @exts = $self->{admin}->load_all_extensions;
208 | }
209 |
210 | my %seen;
211 | foreach my $obj ( @exts ) {
212 | while (my ($method, $glob) = each %{ref($obj) . '::'}) {
213 | next unless $obj->can($method);
214 | next if $method =~ /^_/;
215 | next if $method eq uc($method);
216 | $seen{$method}++;
217 | }
218 | }
219 |
220 | my $who = $self->_caller;
221 | foreach my $name ( sort keys %seen ) {
222 | local $^W;
223 | *{"${who}::$name"} = sub {
224 | ${"${who}::AUTOLOAD"} = "${who}::$name";
225 | goto &{"${who}::AUTOLOAD"};
226 | };
227 | }
228 | }
229 |
230 | sub new {
231 | my ($class, %args) = @_;
232 |
233 | delete $INC{'FindBin.pm'};
234 | {
235 | # to suppress the redefine warning
236 | local $SIG{__WARN__} = sub {};
237 | require FindBin;
238 | }
239 |
240 | # ignore the prefix on extension modules built from top level.
241 | my $base_path = Cwd::abs_path($FindBin::Bin);
242 | unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
243 | delete $args{prefix};
244 | }
245 | return $args{_self} if $args{_self};
246 |
247 | $args{dispatch} ||= 'Admin';
248 | $args{prefix} ||= 'inc';
249 | $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
250 | $args{bundle} ||= 'inc/BUNDLES';
251 | $args{base} ||= $base_path;
252 | $class =~ s/^\Q$args{prefix}\E:://;
253 | $args{name} ||= $class;
254 | $args{version} ||= $class->VERSION;
255 | unless ( $args{path} ) {
256 | $args{path} = $args{name};
257 | $args{path} =~ s!::!/!g;
258 | }
259 | $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
260 | $args{wrote} = 0;
261 |
262 | bless( \%args, $class );
263 | }
264 |
265 | sub call {
266 | my ($self, $method) = @_;
267 | my $obj = $self->load($method) or return;
268 | splice(@_, 0, 2, $obj);
269 | goto &{$obj->can($method)};
270 | }
271 |
272 | sub load {
273 | my ($self, $method) = @_;
274 |
275 | $self->load_extensions(
276 | "$self->{prefix}/$self->{path}", $self
277 | ) unless $self->{extensions};
278 |
279 | foreach my $obj (@{$self->{extensions}}) {
280 | return $obj if $obj->can($method);
281 | }
282 |
283 | my $admin = $self->{admin} or die <<"END_DIE";
284 | The '$method' method does not exist in the '$self->{prefix}' path!
285 | Please remove the '$self->{prefix}' directory and run $0 again to load it.
286 | END_DIE
287 |
288 | my $obj = $admin->load($method, 1);
289 | push @{$self->{extensions}}, $obj;
290 |
291 | $obj;
292 | }
293 |
294 | sub load_extensions {
295 | my ($self, $path, $top) = @_;
296 |
297 | my $should_reload = 0;
298 | unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
299 | unshift @INC, $self->{prefix};
300 | $should_reload = 1;
301 | }
302 |
303 | foreach my $rv ( $self->find_extensions($path) ) {
304 | my ($file, $pkg) = @{$rv};
305 | next if $self->{pathnames}{$pkg};
306 |
307 | local $@;
308 | my $new = eval { local $^W; require $file; $pkg->can('new') };
309 | unless ( $new ) {
310 | warn $@ if $@;
311 | next;
312 | }
313 | $self->{pathnames}{$pkg} =
314 | $should_reload ? delete $INC{$file} : $INC{$file};
315 | push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
316 | }
317 |
318 | $self->{extensions} ||= [];
319 | }
320 |
321 | sub find_extensions {
322 | my ($self, $path) = @_;
323 |
324 | my @found;
325 | File::Find::find( sub {
326 | my $file = $File::Find::name;
327 | return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
328 | my $subpath = $1;
329 | return if lc($subpath) eq lc($self->{dispatch});
330 |
331 | $file = "$self->{path}/$subpath.pm";
332 | my $pkg = "$self->{name}::$subpath";
333 | $pkg =~ s!/!::!g;
334 |
335 | # If we have a mixed-case package name, assume case has been preserved
336 | # correctly. Otherwise, root through the file to locate the case-preserved
337 | # version of the package name.
338 | if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
339 | my $content = Module::Install::_read($subpath . '.pm');
340 | my $in_pod = 0;
341 | foreach ( split //, $content ) {
342 | $in_pod = 1 if /^=\w/;
343 | $in_pod = 0 if /^=cut/;
344 | next if ($in_pod || /^=cut/); # skip pod text
345 | next if /^\s*#/; # and comments
346 | if ( m/^\s*package\s+($pkg)\s*;/i ) {
347 | $pkg = $1;
348 | last;
349 | }
350 | }
351 | }
352 |
353 | push @found, [ $file, $pkg ];
354 | }, $path ) if -d $path;
355 |
356 | @found;
357 | }
358 |
359 |
360 |
361 |
362 |
363 | #####################################################################
364 | # Common Utility Functions
365 |
366 | sub _caller {
367 | my $depth = 0;
368 | my $call = caller($depth);
369 | while ( $call eq __PACKAGE__ ) {
370 | $depth++;
371 | $call = caller($depth);
372 | }
373 | return $call;
374 | }
375 |
376 | # Done in evals to avoid confusing Perl::MinimumVersion
377 | eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
378 | sub _read {
379 | local *FH;
380 | open( FH, '<', $_[0] ) or die "open($_[0]): $!";
381 | my $string = do { local $/; };
382 | close FH or die "close($_[0]): $!";
383 | return $string;
384 | }
385 | END_NEW
386 | sub _read {
387 | local *FH;
388 | open( FH, "< $_[0]" ) or die "open($_[0]): $!";
389 | my $string = do { local $/; };
390 | close FH or die "close($_[0]): $!";
391 | return $string;
392 | }
393 | END_OLD
394 |
395 | sub _readperl {
396 | my $string = Module::Install::_read($_[0]);
397 | $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
398 | $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
399 | $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
400 | return $string;
401 | }
402 |
403 | sub _readpod {
404 | my $string = Module::Install::_read($_[0]);
405 | $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
406 | return $string if $_[0] =~ /\.pod\z/;
407 | $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
408 | $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
409 | $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
410 | $string =~ s/^\n+//s;
411 | return $string;
412 | }
413 |
414 | # Done in evals to avoid confusing Perl::MinimumVersion
415 | eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
416 | sub _write {
417 | local *FH;
418 | open( FH, '>', $_[0] ) or die "open($_[0]): $!";
419 | foreach ( 1 .. $#_ ) {
420 | print FH $_[$_] or die "print($_[0]): $!";
421 | }
422 | close FH or die "close($_[0]): $!";
423 | }
424 | END_NEW
425 | sub _write {
426 | local *FH;
427 | open( FH, "> $_[0]" ) or die "open($_[0]): $!";
428 | foreach ( 1 .. $#_ ) {
429 | print FH $_[$_] or die "print($_[0]): $!";
430 | }
431 | close FH or die "close($_[0]): $!";
432 | }
433 | END_OLD
434 |
435 | # _version is for processing module versions (eg, 1.03_05) not
436 | # Perl versions (eg, 5.8.1).
437 | sub _version ($) {
438 | my $s = shift || 0;
439 | my $d =()= $s =~ /(\.)/g;
440 | if ( $d >= 2 ) {
441 | # Normalise multipart versions
442 | $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
443 | }
444 | $s =~ s/^(\d+)\.?//;
445 | my $l = $1 || 0;
446 | my @v = map {
447 | $_ . '0' x (3 - length $_)
448 | } $s =~ /(\d{1,3})\D?/g;
449 | $l = $l . '.' . join '', @v if @v;
450 | return $l + 0;
451 | }
452 |
453 | sub _cmp ($$) {
454 | _version($_[0]) <=> _version($_[1]);
455 | }
456 |
457 | # Cloned from Params::Util::_CLASS
458 | sub _CLASS ($) {
459 | (
460 | defined $_[0]
461 | and
462 | ! ref $_[0]
463 | and
464 | $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
465 | ) ? $_[0] : undef;
466 | }
467 |
468 | 1;
469 |
470 | # Copyright 2008 - 2011 Adam Kennedy.
471 |
--------------------------------------------------------------------------------
/inc/Module/Install/Metadata.pm:
--------------------------------------------------------------------------------
1 | #line 1
2 | package Module::Install::Metadata;
3 |
4 | use strict 'vars';
5 | use Module::Install::Base ();
6 |
7 | use vars qw{$VERSION @ISA $ISCORE};
8 | BEGIN {
9 | $VERSION = '1.01';
10 | @ISA = 'Module::Install::Base';
11 | $ISCORE = 1;
12 | }
13 |
14 | my @boolean_keys = qw{
15 | sign
16 | };
17 |
18 | my @scalar_keys = qw{
19 | name
20 | module_name
21 | abstract
22 | version
23 | distribution_type
24 | tests
25 | installdirs
26 | };
27 |
28 | my @tuple_keys = qw{
29 | configure_requires
30 | build_requires
31 | requires
32 | recommends
33 | bundles
34 | resources
35 | };
36 |
37 | my @resource_keys = qw{
38 | homepage
39 | bugtracker
40 | repository
41 | };
42 |
43 | my @array_keys = qw{
44 | keywords
45 | author
46 | };
47 |
48 | *authors = \&author;
49 |
50 | sub Meta { shift }
51 | sub Meta_BooleanKeys { @boolean_keys }
52 | sub Meta_ScalarKeys { @scalar_keys }
53 | sub Meta_TupleKeys { @tuple_keys }
54 | sub Meta_ResourceKeys { @resource_keys }
55 | sub Meta_ArrayKeys { @array_keys }
56 |
57 | foreach my $key ( @boolean_keys ) {
58 | *$key = sub {
59 | my $self = shift;
60 | if ( defined wantarray and not @_ ) {
61 | return $self->{values}->{$key};
62 | }
63 | $self->{values}->{$key} = ( @_ ? $_[0] : 1 );
64 | return $self;
65 | };
66 | }
67 |
68 | foreach my $key ( @scalar_keys ) {
69 | *$key = sub {
70 | my $self = shift;
71 | return $self->{values}->{$key} if defined wantarray and !@_;
72 | $self->{values}->{$key} = shift;
73 | return $self;
74 | };
75 | }
76 |
77 | foreach my $key ( @array_keys ) {
78 | *$key = sub {
79 | my $self = shift;
80 | return $self->{values}->{$key} if defined wantarray and !@_;
81 | $self->{values}->{$key} ||= [];
82 | push @{$self->{values}->{$key}}, @_;
83 | return $self;
84 | };
85 | }
86 |
87 | foreach my $key ( @resource_keys ) {
88 | *$key = sub {
89 | my $self = shift;
90 | unless ( @_ ) {
91 | return () unless $self->{values}->{resources};
92 | return map { $_->[1] }
93 | grep { $_->[0] eq $key }
94 | @{ $self->{values}->{resources} };
95 | }
96 | return $self->{values}->{resources}->{$key} unless @_;
97 | my $uri = shift or die(
98 | "Did not provide a value to $key()"
99 | );
100 | $self->resources( $key => $uri );
101 | return 1;
102 | };
103 | }
104 |
105 | foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
106 | *$key = sub {
107 | my $self = shift;
108 | return $self->{values}->{$key} unless @_;
109 | my @added;
110 | while ( @_ ) {
111 | my $module = shift or last;
112 | my $version = shift || 0;
113 | push @added, [ $module, $version ];
114 | }
115 | push @{ $self->{values}->{$key} }, @added;
116 | return map {@$_} @added;
117 | };
118 | }
119 |
120 | # Resource handling
121 | my %lc_resource = map { $_ => 1 } qw{
122 | homepage
123 | license
124 | bugtracker
125 | repository
126 | };
127 |
128 | sub resources {
129 | my $self = shift;
130 | while ( @_ ) {
131 | my $name = shift or last;
132 | my $value = shift or next;
133 | if ( $name eq lc $name and ! $lc_resource{$name} ) {
134 | die("Unsupported reserved lowercase resource '$name'");
135 | }
136 | $self->{values}->{resources} ||= [];
137 | push @{ $self->{values}->{resources} }, [ $name, $value ];
138 | }
139 | $self->{values}->{resources};
140 | }
141 |
142 | # Aliases for build_requires that will have alternative
143 | # meanings in some future version of META.yml.
144 | sub test_requires { shift->build_requires(@_) }
145 | sub install_requires { shift->build_requires(@_) }
146 |
147 | # Aliases for installdirs options
148 | sub install_as_core { $_[0]->installdirs('perl') }
149 | sub install_as_cpan { $_[0]->installdirs('site') }
150 | sub install_as_site { $_[0]->installdirs('site') }
151 | sub install_as_vendor { $_[0]->installdirs('vendor') }
152 |
153 | sub dynamic_config {
154 | my $self = shift;
155 | unless ( @_ ) {
156 | warn "You MUST provide an explicit true/false value to dynamic_config\n";
157 | return $self;
158 | }
159 | $self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
160 | return 1;
161 | }
162 |
163 | sub perl_version {
164 | my $self = shift;
165 | return $self->{values}->{perl_version} unless @_;
166 | my $version = shift or die(
167 | "Did not provide a value to perl_version()"
168 | );
169 |
170 | # Normalize the version
171 | $version = $self->_perl_version($version);
172 |
173 | # We don't support the reall old versions
174 | unless ( $version >= 5.005 ) {
175 | die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
176 | }
177 |
178 | $self->{values}->{perl_version} = $version;
179 | }
180 |
181 | sub all_from {
182 | my ( $self, $file ) = @_;
183 |
184 | unless ( defined($file) ) {
185 | my $name = $self->name or die(
186 | "all_from called with no args without setting name() first"
187 | );
188 | $file = join('/', 'lib', split(/-/, $name)) . '.pm';
189 | $file =~ s{.*/}{} unless -e $file;
190 | unless ( -e $file ) {
191 | die("all_from cannot find $file from $name");
192 | }
193 | }
194 | unless ( -f $file ) {
195 | die("The path '$file' does not exist, or is not a file");
196 | }
197 |
198 | $self->{values}{all_from} = $file;
199 |
200 | # Some methods pull from POD instead of code.
201 | # If there is a matching .pod, use that instead
202 | my $pod = $file;
203 | $pod =~ s/\.pm$/.pod/i;
204 | $pod = $file unless -e $pod;
205 |
206 | # Pull the different values
207 | $self->name_from($file) unless $self->name;
208 | $self->version_from($file) unless $self->version;
209 | $self->perl_version_from($file) unless $self->perl_version;
210 | $self->author_from($pod) unless @{$self->author || []};
211 | $self->license_from($pod) unless $self->license;
212 | $self->abstract_from($pod) unless $self->abstract;
213 |
214 | return 1;
215 | }
216 |
217 | sub provides {
218 | my $self = shift;
219 | my $provides = ( $self->{values}->{provides} ||= {} );
220 | %$provides = (%$provides, @_) if @_;
221 | return $provides;
222 | }
223 |
224 | sub auto_provides {
225 | my $self = shift;
226 | return $self unless $self->is_admin;
227 | unless (-e 'MANIFEST') {
228 | warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
229 | return $self;
230 | }
231 | # Avoid spurious warnings as we are not checking manifest here.
232 | local $SIG{__WARN__} = sub {1};
233 | require ExtUtils::Manifest;
234 | local *ExtUtils::Manifest::manicheck = sub { return };
235 |
236 | require Module::Build;
237 | my $build = Module::Build->new(
238 | dist_name => $self->name,
239 | dist_version => $self->version,
240 | license => $self->license,
241 | );
242 | $self->provides( %{ $build->find_dist_packages || {} } );
243 | }
244 |
245 | sub feature {
246 | my $self = shift;
247 | my $name = shift;
248 | my $features = ( $self->{values}->{features} ||= [] );
249 | my $mods;
250 |
251 | if ( @_ == 1 and ref( $_[0] ) ) {
252 | # The user used ->feature like ->features by passing in the second
253 | # argument as a reference. Accomodate for that.
254 | $mods = $_[0];
255 | } else {
256 | $mods = \@_;
257 | }
258 |
259 | my $count = 0;
260 | push @$features, (
261 | $name => [
262 | map {
263 | ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
264 | } @$mods
265 | ]
266 | );
267 |
268 | return @$features;
269 | }
270 |
271 | sub features {
272 | my $self = shift;
273 | while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
274 | $self->feature( $name, @$mods );
275 | }
276 | return $self->{values}->{features}
277 | ? @{ $self->{values}->{features} }
278 | : ();
279 | }
280 |
281 | sub no_index {
282 | my $self = shift;
283 | my $type = shift;
284 | push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
285 | return $self->{values}->{no_index};
286 | }
287 |
288 | sub read {
289 | my $self = shift;
290 | $self->include_deps( 'YAML::Tiny', 0 );
291 |
292 | require YAML::Tiny;
293 | my $data = YAML::Tiny::LoadFile('META.yml');
294 |
295 | # Call methods explicitly in case user has already set some values.
296 | while ( my ( $key, $value ) = each %$data ) {
297 | next unless $self->can($key);
298 | if ( ref $value eq 'HASH' ) {
299 | while ( my ( $module, $version ) = each %$value ) {
300 | $self->can($key)->($self, $module => $version );
301 | }
302 | } else {
303 | $self->can($key)->($self, $value);
304 | }
305 | }
306 | return $self;
307 | }
308 |
309 | sub write {
310 | my $self = shift;
311 | return $self unless $self->is_admin;
312 | $self->admin->write_meta;
313 | return $self;
314 | }
315 |
316 | sub version_from {
317 | require ExtUtils::MM_Unix;
318 | my ( $self, $file ) = @_;
319 | $self->version( ExtUtils::MM_Unix->parse_version($file) );
320 |
321 | # for version integrity check
322 | $self->makemaker_args( VERSION_FROM => $file );
323 | }
324 |
325 | sub abstract_from {
326 | require ExtUtils::MM_Unix;
327 | my ( $self, $file ) = @_;
328 | $self->abstract(
329 | bless(
330 | { DISTNAME => $self->name },
331 | 'ExtUtils::MM_Unix'
332 | )->parse_abstract($file)
333 | );
334 | }
335 |
336 | # Add both distribution and module name
337 | sub name_from {
338 | my ($self, $file) = @_;
339 | if (
340 | Module::Install::_read($file) =~ m/
341 | ^ \s*
342 | package \s*
343 | ([\w:]+)
344 | \s* ;
345 | /ixms
346 | ) {
347 | my ($name, $module_name) = ($1, $1);
348 | $name =~ s{::}{-}g;
349 | $self->name($name);
350 | unless ( $self->module_name ) {
351 | $self->module_name($module_name);
352 | }
353 | } else {
354 | die("Cannot determine name from $file\n");
355 | }
356 | }
357 |
358 | sub _extract_perl_version {
359 | if (
360 | $_[0] =~ m/
361 | ^\s*
362 | (?:use|require) \s*
363 | v?
364 | ([\d_\.]+)
365 | \s* ;
366 | /ixms
367 | ) {
368 | my $perl_version = $1;
369 | $perl_version =~ s{_}{}g;
370 | return $perl_version;
371 | } else {
372 | return;
373 | }
374 | }
375 |
376 | sub perl_version_from {
377 | my $self = shift;
378 | my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
379 | if ($perl_version) {
380 | $self->perl_version($perl_version);
381 | } else {
382 | warn "Cannot determine perl version info from $_[0]\n";
383 | return;
384 | }
385 | }
386 |
387 | sub author_from {
388 | my $self = shift;
389 | my $content = Module::Install::_read($_[0]);
390 | if ($content =~ m/
391 | =head \d \s+ (?:authors?)\b \s*
392 | ([^\n]*)
393 | |
394 | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
395 | .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
396 | ([^\n]*)
397 | /ixms) {
398 | my $author = $1 || $2;
399 |
400 | # XXX: ugly but should work anyway...
401 | if (eval "require Pod::Escapes; 1") {
402 | # Pod::Escapes has a mapping table.
403 | # It's in core of perl >= 5.9.3, and should be installed
404 | # as one of the Pod::Simple's prereqs, which is a prereq
405 | # of Pod::Text 3.x (see also below).
406 | $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
407 | {
408 | defined $2
409 | ? chr($2)
410 | : defined $Pod::Escapes::Name2character_number{$1}
411 | ? chr($Pod::Escapes::Name2character_number{$1})
412 | : do {
413 | warn "Unknown escape: E<$1>";
414 | "E<$1>";
415 | };
416 | }gex;
417 | }
418 | elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) {
419 | # Pod::Text < 3.0 has yet another mapping table,
420 | # though the table name of 2.x and 1.x are different.
421 | # (1.x is in core of Perl < 5.6, 2.x is in core of
422 | # Perl < 5.9.3)
423 | my $mapping = ($Pod::Text::VERSION < 2)
424 | ? \%Pod::Text::HTML_Escapes
425 | : \%Pod::Text::ESCAPES;
426 | $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
427 | {
428 | defined $2
429 | ? chr($2)
430 | : defined $mapping->{$1}
431 | ? $mapping->{$1}
432 | : do {
433 | warn "Unknown escape: E<$1>";
434 | "E<$1>";
435 | };
436 | }gex;
437 | }
438 | else {
439 | $author =~ s{E}{<}g;
440 | $author =~ s{E}{>}g;
441 | }
442 | $self->author($author);
443 | } else {
444 | warn "Cannot determine author info from $_[0]\n";
445 | }
446 | }
447 |
448 | #Stolen from M::B
449 | my %license_urls = (
450 | perl => 'http://dev.perl.org/licenses/',
451 | apache => 'http://apache.org/licenses/LICENSE-2.0',
452 | apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
453 | artistic => 'http://opensource.org/licenses/artistic-license.php',
454 | artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
455 | lgpl => 'http://opensource.org/licenses/lgpl-license.php',
456 | lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
457 | lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
458 | bsd => 'http://opensource.org/licenses/bsd-license.php',
459 | gpl => 'http://opensource.org/licenses/gpl-license.php',
460 | gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
461 | gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
462 | mit => 'http://opensource.org/licenses/mit-license.php',
463 | mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
464 | open_source => undef,
465 | unrestricted => undef,
466 | restrictive => undef,
467 | unknown => undef,
468 | );
469 |
470 | sub license {
471 | my $self = shift;
472 | return $self->{values}->{license} unless @_;
473 | my $license = shift or die(
474 | 'Did not provide a value to license()'
475 | );
476 | $license = __extract_license($license) || lc $license;
477 | $self->{values}->{license} = $license;
478 |
479 | # Automatically fill in license URLs
480 | if ( $license_urls{$license} ) {
481 | $self->resources( license => $license_urls{$license} );
482 | }
483 |
484 | return 1;
485 | }
486 |
487 | sub _extract_license {
488 | my $pod = shift;
489 | my $matched;
490 | return __extract_license(
491 | ($matched) = $pod =~ m/
492 | (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?)
493 | (=head \d.*|=cut.*|)\z
494 | /xms
495 | ) || __extract_license(
496 | ($matched) = $pod =~ m/
497 | (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?)
498 | (=head \d.*|=cut.*|)\z
499 | /xms
500 | );
501 | }
502 |
503 | sub __extract_license {
504 | my $license_text = shift or return;
505 | my @phrases = (
506 | '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1,
507 | '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
508 | 'Artistic and GPL' => 'perl', 1,
509 | 'GNU general public license' => 'gpl', 1,
510 | 'GNU public license' => 'gpl', 1,
511 | 'GNU lesser general public license' => 'lgpl', 1,
512 | 'GNU lesser public license' => 'lgpl', 1,
513 | 'GNU library general public license' => 'lgpl', 1,
514 | 'GNU library public license' => 'lgpl', 1,
515 | 'GNU Free Documentation license' => 'unrestricted', 1,
516 | 'GNU Affero General Public License' => 'open_source', 1,
517 | '(?:Free)?BSD license' => 'bsd', 1,
518 | 'Artistic license 2\.0' => 'artistic_2', 1,
519 | 'Artistic license' => 'artistic', 1,
520 | 'Apache (?:Software )?license' => 'apache', 1,
521 | 'GPL' => 'gpl', 1,
522 | 'LGPL' => 'lgpl', 1,
523 | 'BSD' => 'bsd', 1,
524 | 'Artistic' => 'artistic', 1,
525 | 'MIT' => 'mit', 1,
526 | 'Mozilla Public License' => 'mozilla', 1,
527 | 'Q Public License' => 'open_source', 1,
528 | 'OpenSSL License' => 'unrestricted', 1,
529 | 'SSLeay License' => 'unrestricted', 1,
530 | 'zlib License' => 'open_source', 1,
531 | 'proprietary' => 'proprietary', 0,
532 | );
533 | while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
534 | $pattern =~ s#\s+#\\s+#gs;
535 | if ( $license_text =~ /\b$pattern\b/i ) {
536 | return $license;
537 | }
538 | }
539 | return '';
540 | }
541 |
542 | sub license_from {
543 | my $self = shift;
544 | if (my $license=_extract_license(Module::Install::_read($_[0]))) {
545 | $self->license($license);
546 | } else {
547 | warn "Cannot determine license info from $_[0]\n";
548 | return 'unknown';
549 | }
550 | }
551 |
552 | sub _extract_bugtracker {
553 | my @links = $_[0] =~ m#L<(
554 | https?\Q://rt.cpan.org/\E[^>]+|
555 | https?\Q://github.com/\E[\w_]+/[\w_]+/issues|
556 | https?\Q://code.google.com/p/\E[\w_\-]+/issues/list
557 | )>#gx;
558 | my %links;
559 | @links{@links}=();
560 | @links=keys %links;
561 | return @links;
562 | }
563 |
564 | sub bugtracker_from {
565 | my $self = shift;
566 | my $content = Module::Install::_read($_[0]);
567 | my @links = _extract_bugtracker($content);
568 | unless ( @links ) {
569 | warn "Cannot determine bugtracker info from $_[0]\n";
570 | return 0;
571 | }
572 | if ( @links > 1 ) {
573 | warn "Found more than one bugtracker link in $_[0]\n";
574 | return 0;
575 | }
576 |
577 | # Set the bugtracker
578 | bugtracker( $links[0] );
579 | return 1;
580 | }
581 |
582 | sub requires_from {
583 | my $self = shift;
584 | my $content = Module::Install::_readperl($_[0]);
585 | my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
586 | while ( @requires ) {
587 | my $module = shift @requires;
588 | my $version = shift @requires;
589 | $self->requires( $module => $version );
590 | }
591 | }
592 |
593 | sub test_requires_from {
594 | my $self = shift;
595 | my $content = Module::Install::_readperl($_[0]);
596 | my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
597 | while ( @requires ) {
598 | my $module = shift @requires;
599 | my $version = shift @requires;
600 | $self->test_requires( $module => $version );
601 | }
602 | }
603 |
604 | # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
605 | # numbers (eg, 5.006001 or 5.008009).
606 | # Also, convert double-part versions (eg, 5.8)
607 | sub _perl_version {
608 | my $v = $_[-1];
609 | $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
610 | $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
611 | $v =~ s/(\.\d\d\d)000$/$1/;
612 | $v =~ s/_.+$//;
613 | if ( ref($v) ) {
614 | # Numify
615 | $v = $v + 0;
616 | }
617 | return $v;
618 | }
619 |
620 | sub add_metadata {
621 | my $self = shift;
622 | my %hash = @_;
623 | for my $key (keys %hash) {
624 | warn "add_metadata: $key is not prefixed with 'x_'.\n" .
625 | "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/;
626 | $self->{values}->{$key} = $hash{$key};
627 | }
628 | }
629 |
630 |
631 | ######################################################################
632 | # MYMETA Support
633 |
634 | sub WriteMyMeta {
635 | die "WriteMyMeta has been deprecated";
636 | }
637 |
638 | sub write_mymeta_yaml {
639 | my $self = shift;
640 |
641 | # We need YAML::Tiny to write the MYMETA.yml file
642 | unless ( eval { require YAML::Tiny; 1; } ) {
643 | return 1;
644 | }
645 |
646 | # Generate the data
647 | my $meta = $self->_write_mymeta_data or return 1;
648 |
649 | # Save as the MYMETA.yml file
650 | print "Writing MYMETA.yml\n";
651 | YAML::Tiny::DumpFile('MYMETA.yml', $meta);
652 | }
653 |
654 | sub write_mymeta_json {
655 | my $self = shift;
656 |
657 | # We need JSON to write the MYMETA.json file
658 | unless ( eval { require JSON; 1; } ) {
659 | return 1;
660 | }
661 |
662 | # Generate the data
663 | my $meta = $self->_write_mymeta_data or return 1;
664 |
665 | # Save as the MYMETA.yml file
666 | print "Writing MYMETA.json\n";
667 | Module::Install::_write(
668 | 'MYMETA.json',
669 | JSON->new->pretty(1)->canonical->encode($meta),
670 | );
671 | }
672 |
673 | sub _write_mymeta_data {
674 | my $self = shift;
675 |
676 | # If there's no existing META.yml there is nothing we can do
677 | return undef unless -f 'META.yml';
678 |
679 | # We need Parse::CPAN::Meta to load the file
680 | unless ( eval { require Parse::CPAN::Meta; 1; } ) {
681 | return undef;
682 | }
683 |
684 | # Merge the perl version into the dependencies
685 | my $val = $self->Meta->{values};
686 | my $perl = delete $val->{perl_version};
687 | if ( $perl ) {
688 | $val->{requires} ||= [];
689 | my $requires = $val->{requires};
690 |
691 | # Canonize to three-dot version after Perl 5.6
692 | if ( $perl >= 5.006 ) {
693 | $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
694 | }
695 | unshift @$requires, [ perl => $perl ];
696 | }
697 |
698 | # Load the advisory META.yml file
699 | my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
700 | my $meta = $yaml[0];
701 |
702 | # Overwrite the non-configure dependency hashs
703 | delete $meta->{requires};
704 | delete $meta->{build_requires};
705 | delete $meta->{recommends};
706 | if ( exists $val->{requires} ) {
707 | $meta->{requires} = { map { @$_ } @{ $val->{requires} } };
708 | }
709 | if ( exists $val->{build_requires} ) {
710 | $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
711 | }
712 |
713 | return $meta;
714 | }
715 |
716 | 1;
717 |
--------------------------------------------------------------------------------