PYX-XMLSchema-List
view release on metacpan or search on metacpan
0.06 2023-10-19T10:12:48+02:00
- Fix Makefile.PL which fails with no '.' in @INC.
0.05 2023-10-19T10:09:18+02:00
- Improve LICENSE AND COPYRIGHT section in doc.
- Improve METHODS section in doc.
- Improve SYNOPSIS section in doc.
- Move bugtracker to github.
- Rename example to better name.
- Update Module::Install to 1.21 version.
- Update author github username.
- Update author name.
- Update copyright years.
0.04 2015-10-29T21:44:46+01:00
- Fix warning in length(undef).
0.03 2015-10-25T09:23:29+01:00
- Fix test requires.
0.02 2015-10-22T19:44:43+02:00
- Add reset() method.
- Add stats() method.
- Add tests.
- Clean and optimalize code.
- Fix output (trailing whitespace on end of line).
- Improve tests to better coverity.
- Improve SEE ALSO section in doc.
- Move author tests to xt/ directory.
- Update Module::Install to 1.16 version.
0.01 2015-04-01T01:11:02+02:00
- First version.
Copyright (c) 2015-2023 Michal Josef Å paÄek
All rights reserved.
Redistribution and use in source and binary forms, with or without modification,
are permitted provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation and/or
other materials provided with the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
package PYX::XMLSchema::List;
use strict;
use warnings;
use Class::Utils qw(set_params);
use Error::Pure qw(err);
use List::Util qw(reduce);
use PYX::Parser;
use Readonly;
# Constants.
Readonly::Scalar our $EMPTY_STR => q{};
Readonly::Scalar our $SPACE => q{ };
our $VERSION = 0.06;
# Constructor.
sub new {
my ($class, @params) = @_;
my $self = bless {}, $class;
# Output handler.
$self->{'output_handler'} = \*STDOUT;
# Process params.
set_params($self, @params);
# PYX::Parser object.
$self->{'_pyx_parser'} = PYX::Parser->new(
'callbacks' => {
'attribute' => \&_call_attribute,
'final' => \&_call_final,
'start_element' => \&_call_start_element,
},
'non_parser_options' => {
'schemas' => {},
},
'output_handler' => $self->{'output_handler'},
);
# Object.
return $self;
}
# Parse pyx text or array of pyx text.
sub parse {
my ($self, $pyx, $out) = @_;
$self->{'_pyx_parser'}->parse($pyx, $out);
return;
}
# Parse file with pyx text.
sub parse_file {
my ($self, $file, $out) = @_;
$self->{'_pyx_parser'}->parse_file($file, $out);
return;
}
# Parse from handler.
sub parse_handler {
my ($self, $input_file_handler, $out) = @_;
$self->{'_pyx_parser'}->parse_handler($input_file_handler, $out);
return;
}
# Reset parser.
sub reset {
my $self = shift;
$self->{'_pyx_parser'}->{'non_parser_options'}->{'schemas'} = {};
return;
}
# Gets statistics structure.
sub stats {
my $self = shift;
my $schemas_hr = $self->{'_pyx_parser'}->{'non_parser_options'}
->{'schemas'};
return $schemas_hr;
}
# Attribute callback.
sub _call_attribute {
my ($pyx_parser_obj, $key, $val) = @_;
my $schemas_hr = $pyx_parser_obj->{'non_parser_options'}->{'schemas'};
if (my ($first, $sec) = _parse_schema($key)) {
# Get URL for XML schema.
if ($first eq 'xmlns') {
my $schema = $sec;
if (! exists $schemas_hr->{$schema}) {
_init_struct($schemas_hr, $schema, $val);
} else {
$schemas_hr->{$schema}->[0] = $val;
}
# Add attribute to XML schema statistics.
} else {
my $schema = $first;
_init_struct($schemas_hr, $schema);
$schemas_hr->{$schema}->[1]->{'attr'}++;
}
}
return;
}
# Finalize callback.
sub _call_final {
my $pyx_parser_obj = shift;
my $schemas_hr = $pyx_parser_obj->{'non_parser_options'}->{'schemas'};
my $out = $pyx_parser_obj->{'output_handler'};
my $max_string = reduce { length($a) > length($b) ? $a : $b } keys %{$schemas_hr};
my $max_len = defined $max_string ? length $max_string : 0;
foreach my $key (sort keys %{$schemas_hr}) {
printf {$out} "[ %-${max_len}s ] (E: %04d, A: %04d)%s\n", $key,
$schemas_hr->{$key}->[1]->{'element'},
$schemas_hr->{$key}->[1]->{'attr'},
$schemas_hr->{$key}->[0] ne $EMPTY_STR
? $SPACE.$schemas_hr->{$key}->[0]
: $EMPTY_STR;
}
if (! keys %{$schemas_hr}) {
print {$out} "No XML schemas.\n";
}
return;
}
# Start of element callback.
sub _call_start_element {
my ($pyx_parser_obj, $elem) = @_;
my $schemas_hr = $pyx_parser_obj->{'non_parser_options'}->{'schemas'};
if (defined(my $schema = _parse_schema($elem))) {
_init_struct($schemas_hr, $schema);
$schemas_hr->{$schema}->[1]->{'element'}++;
}
return;
}
# Initialize XML schema structure.
sub _init_struct {
my ($schemas_hr, $schema, $uri) = @_;
if (! defined $uri) {
$uri = $EMPTY_STR;
}
if (! exists $schemas_hr->{$schema}) {
$schemas_hr->{$schema} = [$uri, {
'attr' => 0,
'element' => 0,
}];
}
return;
}
# Parse XML schema from string.
sub _parse_schema {
my $string = shift;
if ($string =~ m/^(.+?):(.+)$/ms) {
return wantarray ? ($1, $2) : $1;
}
return;
}
1;
__END__
=pod
=encoding utf8
=head1 NAME
PYX::XMLSchema::List - Processing PYX data or file and print list of XML schemas.
=head1 SYNOPSIS
use PYX::XMLSchema::List;
my $obj = PYX::XMLSchema::List->new(%parameters);
$obj->parse($pyx, $out);
$obj->parse_file($input_file, $out);
$obj->parse_handler($input_file_handler, $out);
$obj->reset;
my $stats_hr = $obj->stats;
=head1 METHODS
=head2 C<new>
my $obj = PYX::XMLSchema::List->new(%parameters);
Constructor.
=over 8
=item * C<output_handler>
Output handler.
Default value is \*STDOUT.
=back
Returns instance of object.
=head2 C<parse>
$obj->parse($pyx, $out);
Parse PYX text or array of PYX text and print list of XML schemas of PYX input.
If C<$out> not present, use 'output_handler'.
Returns undef.
=head2 C<parse_file>
$obj->parse_file($input_file, $out);
Parse file with PYX data and print list of XML schemas of PYX input.
If C<$out> not present, use 'output_handler'.
Returns undef.
=head2 C<parse_handler>
$obj->parse_handler($input_file_handler, $out);
Parse PYX handler and print list of XML schemas of PYX input.
If C<$out> not present, use 'output_handler'.
Returns undef.
=head2 C<reset>
$obj->reset;
Resets internal structure with statistics.
Returns undef.
=head2 C<stats>
my $stats_hr = $obj->stats;
Gets statistics structure.
Returns undef.
=head1 ERRORS
new():
From Class::Utils::set_params():
Unknown parameter '%s'.
=head1 EXAMPLE1
=for comment filename=list_xml_schemas.pl
use strict;
use warnings;
use PYX::XMLSchema::List;
# Example data.
my $pyx = <<'END';
(foo
Axmlns:bar http://bar.foo
Axmlns:foo http://foo.bar
Afoo:bar baz
(foo:bar
Axml:lang en
Abar:foo baz
)foo:bar
)foo
END
# PYX::XMLSchema::List object.
my $obj = PYX::XMLSchema::List->new;
# Parse.
$obj->parse($pyx);
# Output:
# [ bar ] (E: 0000, A: 0001) http://bar.foo
# [ foo ] (E: 0001, A: 0001) http://foo.bar
# [ xml ] (E: 0000, A: 0001)
=head1 DEPENDENCIES
L<Class::Utils>,
L<Error::Pure>,
L<List::Util>,
L<PYX::Parser>,
L<Readonly>.
=head1 SEE ALSO
=over
=item L<PYX>
A perl module for PYX handling.
=item L<Task::PYX>
Install the PYX modules.
=back
=head1 REPOSITORY
L<https://github.com/michal-josef-spacek/PYX-XMLSchema-List>
=head1 AUTHOR
Michal Josef Å paÄek L<mailto:skim@cpan.org>
L<http://skim.cz>
=head1 LICENSE AND COPYRIGHT
© 2015-2023 Michal Josef Å paÄek
BSD 2-Clause License
=head1 VERSION
0.06
=cut
Changes
examples/list_xml_schemas.pl
inc/Module/Install.pm
inc/Module/Install/AuthorRequires.pm
inc/Module/Install/AuthorTests.pm
inc/Module/Install/Base.pm
inc/Module/Install/Can.pm
inc/Module/Install/Fetch.pm
inc/Module/Install/Makefile.pm
inc/Module/Install/Metadata.pm
inc/Module/Install/ReadmeFromPod.pm
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
LICENSE
List.pm
Makefile.PL
MANIFEST This list of files
META.yml
README
SIGNATURE
t/data/ex1.pyx
t/data/ex2.pyx
t/data/ex3.pyx
t/PYX-XMLSchema-List/01-use.t
t/PYX-XMLSchema-List/02-version.t
t/PYX-XMLSchema-List/03-new.t
t/PYX-XMLSchema-List/04-parse.t
t/PYX-XMLSchema-List/05-parse_file.t
t/PYX-XMLSchema-List/06-parse_handler.t
t/PYX-XMLSchema-List/07-reset.t
t/PYX-XMLSchema-List/08-stats.t
xt/PYX-XMLSchema-List/01-pod_coverage.t
xt/PYX-XMLSchema-List/02-pod.t
---
abstract: 'Processing PYX data or file and print list of XML schemas.'
author:
- 'Michal Josef Spacek <skim@cpan.org>'
build_requires:
English: 0
Error::Pure::Utils: 0.22
ExtUtils::MakeMaker: 6.36
File::Object: 0.07
Perl6::Slurp: 0
Test::More: 0
Test::NoWarnings: 0
Test::Output: 1.02
configure_requires:
ExtUtils::MakeMaker: 6.36
distribution_type: module
dynamic_config: 1
generated_by: 'Module::Install version 1.21'
license: bsd
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: PYX-XMLSchema-List
no_index:
directory:
- examples
- inc
- t
- xt
requires:
Class::Utils: 0.05
Error::Pure: 0.16
List::Util: 0
PYX::Parser: 0.02
Readonly: 0
perl: 5.6.0
resources:
bugtracker: https://github.com/michal-josef-spacek/PYX-XMLSchema-List/issues
homepage: https://github.com/michal-josef-spacek/PYX-XMLSchema-List
license: http://opensource.org/licenses/bsd-license.php
repository: git://github.com/michal-josef-spacek/PYX-XMLSchema-List
version: '0.06'
Makefile.PL view on Meta::CPAN
use lib '.';
use strict;
use warnings;
use inc::Module::Install;
# Definition.
abstract 'Processing PYX data or file and print list of XML schemas.';
author 'Michal Josef Spacek <skim@cpan.org>';
author_requires 'English' => 0;
author_requires 'File::Object' => 0.07;
author_requires 'Test::More' => 0;
author_requires 'Test::NoWarnings' => 0;
author_requires 'Test::Pod' => 0;
author_requires 'Test::Pod::Coverage' => 0;
license 'bsd';
name 'PYX-XMLSchema-List';
readme_from 'List.pm';
recursive_author_tests('xt');
requires 'Class::Utils' => 0.05;
requires 'Error::Pure' => 0.16;
requires 'List::Util' => 0;
requires 'PYX::Parser' => 0.02;
requires 'Readonly' => 0;
requires 'perl' => '5.6.0';
resources 'bugtracker' => 'https://github.com/michal-josef-spacek/PYX-XMLSchema-List/issues';
resources 'homepage' => 'https://github.com/michal-josef-spacek/PYX-XMLSchema-List';
resources 'repository' => 'git://github.com/michal-josef-spacek/PYX-XMLSchema-List';
test_requires 'English' => 0;
test_requires 'File::Object' => 0.07;
test_requires 'Error::Pure::Utils' => 0.22;
test_requires 'Perl6::Slurp' => 0;
test_requires 'Test::More' => 0;
test_requires 'Test::NoWarnings' => 0;
test_requires 'Test::Output' => 1.02;
tests_recursive;
version '0.06';
# Run.
WriteAll();
NAME
PYX::XMLSchema::List - Processing PYX data or file and print list of XML
schemas.
SYNOPSIS
use PYX::XMLSchema::List;
my $obj = PYX::XMLSchema::List->new(%parameters);
$obj->parse($pyx, $out);
$obj->parse_file($input_file, $out);
$obj->parse_handler($input_file_handler, $out);
$obj->reset;
my $stats_hr = $obj->stats;
METHODS
"new"
my $obj = PYX::XMLSchema::List->new(%parameters);
Constructor.
* "output_handler"
Output handler.
Default value is \*STDOUT.
Returns instance of object.
"parse"
$obj->parse($pyx, $out);
Parse PYX text or array of PYX text and print list of XML schemas of PYX
input. If $out not present, use 'output_handler'.
Returns undef.
"parse_file"
$obj->parse_file($input_file, $out);
Parse file with PYX data and print list of XML schemas of PYX input. If
$out not present, use 'output_handler'.
Returns undef.
"parse_handler"
$obj->parse_handler($input_file_handler, $out);
Parse PYX handler and print list of XML schemas of PYX input. If $out
not present, use 'output_handler'.
Returns undef.
"reset"
$obj->reset;
Resets internal structure with statistics.
Returns undef.
"stats"
my $stats_hr = $obj->stats;
Gets statistics structure.
Returns undef.
ERRORS
new():
From Class::Utils::set_params():
Unknown parameter '%s'.
EXAMPLE1
use strict;
use warnings;
use PYX::XMLSchema::List;
# Example data.
my $pyx = <<'END';
(foo
Axmlns:bar http://bar.foo
Axmlns:foo http://foo.bar
Afoo:bar baz
(foo:bar
Axml:lang en
Abar:foo baz
)foo:bar
)foo
END
# PYX::XMLSchema::List object.
my $obj = PYX::XMLSchema::List->new;
# Parse.
$obj->parse($pyx);
# Output:
# [ bar ] (E: 0000, A: 0001) http://bar.foo
# [ foo ] (E: 0001, A: 0001) http://foo.bar
# [ xml ] (E: 0000, A: 0001)
DEPENDENCIES
Class::Utils, Error::Pure, List::Util, PYX::Parser, Readonly.
SEE ALSO
PYX A perl module for PYX handling.
Task::PYX
Install the PYX modules.
REPOSITORY
<https://github.com/michal-josef-spacek/PYX-XMLSchema-List>
AUTHOR
Michal Josef Å paÄek <mailto:skim@cpan.org>
<http://skim.cz>
LICENSE AND COPYRIGHT
© 2015-2023 Michal Josef Å paÄek
BSD 2-Clause License
VERSION
0.06
This file contains message digests of all files listed in MANIFEST,
signed via the Module::Signature module, version 0.87.
To verify the content in this distribution, first make sure you have
Module::Signature installed, then type:
% cpansign -v
It will check each file's integrity, as well as the signature's
validity. If "==> Signature verified OK! <==" is not displayed,
the distribution may already have been compromised, and you should
not run its Makefile.PL or Build.PL.
-----BEGIN PGP SIGNED MESSAGE-----
Hash: RIPEMD160
SHA256 a91cb5decb6d8e7835ce5d8644c9058fea9860c89f6a4dc726bbe28d9fcc990a Changes
SHA256 3eda4295af098a9626e4f5855d21c245deb5c775997162e52d29ba812f2c1e7f LICENSE
SHA256 bdd5837473b1a66798e98c1752a10f457d61a87dc3014966de113f24fbf49324 List.pm
SHA256 6ff6183564685d82cf9875cf0b47f96d914828a7ea91b97064858751aa8d0540 MANIFEST
SHA256 bdb603d183de808d1408f629eb716044266cff170d63f3933264e120ee86cd41 META.yml
SHA256 7cd658b395f322827083428ff995c3e9de4e13a9cfd50fa85ccf394190a1f8d4 Makefile.PL
SHA256 aef1b0bd3f3e44e39edf15e58369a9f7bb8454d98ff596425eb389873e5dd0aa README
SHA256 c8d9aefe6ae1eae148bfa81e3b7610001b82493992ea92d65bcc9969b6a12484 examples/list_xml_schemas.pl
SHA256 cd5397bbe618f5bbd4e12a33b0cf5d21114e771c2dbd0ce28e2135beb52c35a8 inc/Module/Install.pm
SHA256 8bd506c33fb78f10f6451413e931ca23541fcc4eebe05fcb7c7c9577341223c4 inc/Module/Install/AuthorRequires.pm
SHA256 1b5430a46a35142ef8914d8c745196fca825defc9dfa7e389299bf294613825e inc/Module/Install/AuthorTests.pm
SHA256 798836f9ccb8d204b1be31fc3835631f57e9d818b21a8f0d14bfcfb82ff4a72a inc/Module/Install/Base.pm
SHA256 d64cd4c16f83c5baf11f64a44bea3a0abc060a49da5aba040f0eb01394bf75ab inc/Module/Install/Can.pm
SHA256 65d7a6098bf3f829e8c1c2865476d3537aa6f0ad0ffc9149e10812c856529043 inc/Module/Install/Fetch.pm
SHA256 70c4b77acab3ff51dfb318110369607cb109e1c319459249623b787cf3859750 inc/Module/Install/Makefile.pm
SHA256 14556386168007ce913e669fc08a332ccdb6140246fd55a90c879b5190c1b57a inc/Module/Install/Metadata.pm
SHA256 53825bc78e4c910b888160bc148c8bc211be58e02b99c8edcbf4854f95faa049 inc/Module/Install/ReadmeFromPod.pm
SHA256 4c746c02c5cc19bed4c352e76205b4adff4c45ce8310d71294e1b83c059659c2 inc/Module/Install/Win32.pm
SHA256 d3d9b4583243c470ae895defa4c44564485b53693cba1c50ab0320768f443e97 inc/Module/Install/WriteAll.pm
SHA256 edd25b8608c93eba278d65ffaf4d5f1f8135d54bbae6ac53d3f439c1583a3820 t/PYX-XMLSchema-List/01-use.t
SHA256 43c61b130592771983328b9076693651e3120cbdb751549a1b4a27d42a93558d t/PYX-XMLSchema-List/02-version.t
SHA256 13e9b985ed2254b87f11d8fea6ed01663ed7e8d83164e6a6036622a565de3428 t/PYX-XMLSchema-List/03-new.t
SHA256 d39dc000e546109f1b0dbd706d9f6fbd33c8c48df36ec8b0b81d70bfc3882082 t/PYX-XMLSchema-List/04-parse.t
SHA256 33f4dc75e169d46195bf365acc3c6e778b01116a1383110ce11cd6e9319f6e43 t/PYX-XMLSchema-List/05-parse_file.t
SHA256 f904db7104f3fd2d39d7a4db8a11b851c9e2c5f5c96e7fb78bff8125c03e4635 t/PYX-XMLSchema-List/06-parse_handler.t
SHA256 6addb8716b0fc730c75ceb399d16bfc66ebe7cdd48bce19ab8bb04fb650332e5 t/PYX-XMLSchema-List/07-reset.t
SHA256 1bc11a91dda5bbad32d55189a5a283821a83c5ca2d1bba32262607b1e81dd41e t/PYX-XMLSchema-List/08-stats.t
SHA256 59ec4823a8540a0b39c397b49664fa2e21d841d45a0e9007a0a77be1fd99c161 t/data/ex1.pyx
SHA256 3c400b8934c73d2726d9f0596ffb31969231199ff04dae88e245aa87d44a6d45 t/data/ex2.pyx
SHA256 a4460154835949ff56f75e87ef219c8993e21ba1ffef7060e2e93abdd99f0e0c t/data/ex3.pyx
SHA256 f2dc0d5b097ac1807ad85bab8e44db5682cc6977d9f30271334787d449e2f883 xt/PYX-XMLSchema-List/01-pod_coverage.t
SHA256 e275c96f71ae3ff04f9987a7e81f568833196f6c6f9f81883ef377ad3e92bb45 xt/PYX-XMLSchema-List/02-pod.t
-----BEGIN PGP SIGNATURE-----
iQIzBAEBAwAdFiEEbEiOwSagsghKcON6ojV9Rpe/B8sFAmUw5QMACgkQojV9Rpe/
B8vEhQ/+Pz2yZ6zl7jM9Vg0YHulbXCbbzev9JSlbIHsPYM4wmeWAI29dxMoicVQP
mqWV+SUkvrXuAOs6bDPSBW+LLunRyvtYRKanSNq7UXswTMF25fgcb44oM5aOaIdm
pPO/RttuPb8kK0Il7HLxUBQYWwpkKmmaxCtHGfRr+O8G3iRbhBFbJGl8rvJ0USUM
PBmPP72+F0eWvN2URYUkHG+/fBYJVCzM/EU0kFvcvkdAgIWg0T13x3L0ukOILzMC
WUelVsmJmC1Y+SroKNpwiKJtpdvqQHjIk3pjTDyu/Q/+TjPOH0/9hd7GB7MHqNJu
z6mEJ1ZyFOeXHR6d6vSI1PBv+oEHmHGeek98OjVDVP3kevisw91k8AMoxjNUI7wx
BQon2X7+7VMB0IhjfpPgW7Ls2WnzT317Zw46M9IQ1HhtZSpy6xYjVJGWXZXM9lai
1Mxt3ciUi8AuMUQwptQZcXsswMl01gDE7QNtY7RxGVrkm6QbcuqRFoAwj4nNzhk2
rCZUGPXFVYimzR+aMTY3vLNeB+8FATXHc4VCcTK2YsF8Tlyr8AdKD0GJ5m8fSwJr
7Na+Y0LpszNHC0Ykec8sGwEnYZGtbKXe5cEgq5+IbB1Z6mVFmXdIToYc3KslVTp1
Z7qLT+nWHXD52o0VysRmNzk5WK1FYAFACzojOOaXu5AE2V1AH+c=
=Zo5e
-----END PGP SIGNATURE-----
examples/list_xml_schemas.pl view on Meta::CPAN
#!/usr/bin/env perl
use strict;
use warnings;
use PYX::XMLSchema::List;
# Example data.
my $pyx = <<'END';
(foo
Axmlns:bar http://bar.foo
Axmlns:foo http://foo.bar
Afoo:bar baz
(foo:bar
Axml:lang en
Abar:foo baz
)foo:bar
)foo
END
# PYX::XMLSchema::List object.
my $obj = PYX::XMLSchema::List->new;
# Parse.
$obj->parse($pyx);
# Output:
# [ bar ] (E: 0000, A: 0001) http://bar.foo
# [ foo ] (E: 0001, A: 0001) http://foo.bar
# [ xml ] (E: 0000, A: 0001)
inc/Module/Install.pm view on Meta::CPAN
#line 1
package Module::Install;
# For any maintainers:
# The load order for Module::Install is a bit magic.
# It goes something like this...
#
# IF ( host has Module::Install installed, creating author mode ) {
# 1. Makefile.PL calls "use inc::Module::Install"
# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
# 3. The installed version of inc::Module::Install loads
# 4. inc::Module::Install calls "require Module::Install"
# 5. The ./inc/ version of Module::Install loads
# } ELSE {
# 1. Makefile.PL calls "use inc::Module::Install"
# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
# 3. The ./inc/ version of Module::Install loads
# }
use 5.006;
use strict 'vars';
use Cwd ();
use File::Find ();
use File::Path ();
use vars qw{$VERSION $MAIN};
BEGIN {
# All Module::Install core packages now require synchronised versions.
# This will be used to ensure we don't accidentally load old or
# different versions of modules.
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
$VERSION = '1.21';
# Storage for the pseudo-singleton
$MAIN = undef;
*inc::Module::Install::VERSION = *VERSION;
@inc::Module::Install::ISA = __PACKAGE__;
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
#-------------------------------------------------------------
# all of the following checks should be included in import(),
# to allow "eval 'require Module::Install; 1' to test
# installation of Module::Install. (RT #51267)
#-------------------------------------------------------------
# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) { die <<"END_DIE" }
Please invoke ${\__PACKAGE__} with:
use inc::${\__PACKAGE__};
not:
use ${\__PACKAGE__};
END_DIE
# This reportedly fixes a rare Win32 UTC file time issue, but
# as this is a non-cross-platform XS module not in the core,
# we shouldn't really depend on it. See RT #24194 for detail.
# (Also, this module only supports Perl 5.6 and above).
eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
# If the script that is loading Module::Install is from the future,
# then make will detect this and cause it to re-run over and over
# again. This is bad. Rather than taking action to touch it (which
# is unreliable on some platforms and requires write permissions)
# for now we should catch this and refuse to run.
if ( -f $0 ) {
my $s = (stat($0))[9];
# If the modification time is only slightly in the future,
# sleep briefly to remove the problem.
my $a = $s - time;
if ( $a > 0 and $a < 5 ) { sleep 5 }
# Too far in the future, throw an error.
my $t = time;
if ( $s > $t ) { die <<"END_DIE" }
Your installer $0 has a modification time in the future ($s > $t).
This is known to create infinite loops in make.
Please correct this, then run $0 again.
END_DIE
}
# Build.PL was formerly supported, but no longer is due to excessive
# difficulty in implementing every single feature twice.
if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
Module::Install no longer supports Build.PL.
It was impossible to maintain duel backends, and has been deprecated.
Please remove all Build.PL files and only use the Makefile.PL installer.
END_DIE
#-------------------------------------------------------------
# To save some more typing in Module::Install installers, every...
# use inc::Module::Install
# ...also acts as an implicit use strict.
$^H |= strict::bits(qw(refs subs vars));
#-------------------------------------------------------------
unless ( -f $self->{file} ) {
foreach my $key (keys %INC) {
delete $INC{$key} if $key =~ /Module\/Install/;
}
local $^W;
require "$self->{path}/$self->{dispatch}.pm";
File::Path::mkpath("$self->{prefix}/$self->{author}");
$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
$self->{admin}->init;
@_ = ($class, _self => $self);
goto &{"$self->{name}::import"};
}
local $^W;
*{"${who}::AUTOLOAD"} = $self->autoload;
$self->preload;
# Unregister loader and worker packages so subdirs can use them again
delete $INC{'inc/Module/Install.pm'};
delete $INC{'Module/Install.pm'};
# Save to the singleton
$MAIN = $self;
return 1;
}
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::getcwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::getcwd();
if ( my $code = $sym->{$pwd} ) {
# Delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
unless ($$sym =~ s/([^:]+)$//) {
# XXX: it looks like we can't retrieve the missing function
# via $$sym (usually $main::AUTOLOAD) in this case.
# I'm still wondering if we should slurp Makefile.PL to
# get some context or not ...
my ($package, $file, $line) = caller;
die <<"EOT";
Unknown function is found at $file line $line.
Execution of $file aborted due to runtime errors.
If you're a contributor to a project, you may need to install
some Module::Install extensions from CPAN (or other repository).
If you're a user of a module, please contact the author.
EOT
}
my $method = $1;
if ( uc($method) eq $method ) {
# Do nothing
return;
} elsif ( $method =~ /^_/ and $self->can($method) ) {
# Dispatch to the root M:I class
return $self->$method(@_);
}
# Dispatch to the appropriate plugin
unshift @_, ( $self, $1 );
goto &{$self->can('call')};
};
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
}
my @exts = @{$self->{extensions}};
unless ( @exts ) {
@exts = $self->{admin}->load_all_extensions;
}
my %seen;
foreach my $obj ( @exts ) {
while (my ($method, $glob) = each %{ref($obj) . '::'}) {
next unless $obj->can($method);
next if $method =~ /^_/;
next if $method eq uc($method);
$seen{$method}++;
}
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
local $^W;
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
delete $INC{'FindBin.pm'};
{
# to suppress the redefine warning
local $SIG{__WARN__} = sub {};
require FindBin;
}
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) {
delete $args{prefix};
}
return $args{_self} if $args{_self};
$base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS';
$args{dispatch} ||= 'Admin';
$args{prefix} ||= 'inc';
$args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
$args{bundle} ||= 'inc/BUNDLES';
$args{base} ||= $base_path;
$class =~ s/^\Q$args{prefix}\E:://;
$args{name} ||= $class;
$args{version} ||= $class->VERSION;
unless ( $args{path} ) {
$args{path} = $args{name};
$args{path} =~ s!::!/!g;
}
$args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
foreach my $obj (@{$self->{extensions}}) {
return $obj if $obj->can($method);
}
my $admin = $self->{admin} or die <<"END_DIE";
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE
my $obj = $admin->load($method, 1);
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
my $should_reload = 0;
unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
$should_reload = 1;
}
foreach my $rv ( $self->find_extensions($path) ) {
my ($file, $pkg) = @{$rv};
next if $self->{pathnames}{$pkg};
local $@;
my $new = eval { local $^W; require $file; $pkg->can('new') };
unless ( $new ) {
warn $@ if $@;
next;
}
$self->{pathnames}{$pkg} =
$should_reload ? delete $INC{$file} : $INC{$file};
push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( {no_chdir => 1, wanted => sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
$file = "$self->{path}/$subpath.pm";
my $pkg = "$self->{name}::$subpath";
$pkg =~ s!/!::!g;
# If we have a mixed-case package name, assume case has been preserved
# correctly. Otherwise, root through the file to locate the case-preserved
# version of the package name.
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
my $content = Module::Install::_read($File::Find::name);
my $in_pod = 0;
foreach ( split /\n/, $content ) {
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/); # skip pod text
next if /^\s*#/; # and comments
if ( m/^\s*package\s+($pkg)\s*;/i ) {
$pkg = $1;
last;
}
}
}
push @found, [ $file, $pkg ];
}}, $path ) if -d $path;
@found;
}
#####################################################################
# Common Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
local *FH;
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
binmode FH;
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
sub _readperl {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
$string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
return $string;
}
sub _readpod {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
return $string if $_[0] =~ /\.pod\z/;
$string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
$string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
$string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
$string =~ s/^\n+//s;
return $string;
}
sub _write {
local *FH;
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
binmode FH;
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version {
my $s = shift || 0;
my $d =()= $s =~ /(\.)/g;
if ( $d >= 2 ) {
# Normalise multipart versions
$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
}
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map {
$_ . '0' x (3 - length $_)
} $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
sub _cmp {
_version($_[1]) <=> _version($_[2]);
}
# Cloned from Params::Util::_CLASS
sub _CLASS {
(
defined $_[0]
and
! ref $_[0]
and
$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
) ? $_[0] : undef;
}
1;
# Copyright 2008 - 2012 Adam Kennedy.
inc/Module/Install/AuthorRequires.pm view on Meta::CPAN
#line 1
use strict;
use warnings;
package Module::Install::AuthorRequires;
use base 'Module::Install::Base';
# cargo cult
BEGIN {
our $VERSION = '0.02';
our $ISCORE = 1;
}
sub author_requires {
my $self = shift;
return $self->{values}->{author_requires}
unless @_;
my @added;
while (@_) {
my $mod = shift or last;
my $version = shift || 0;
push @added, [$mod => $version];
}
push @{ $self->{values}->{author_requires} }, @added;
$self->admin->author_requires(@added);
return map { @$_ } @added;
}
1;
__END__
#line 92
inc/Module/Install/AuthorTests.pm view on Meta::CPAN
#line 1
package Module::Install::AuthorTests;
use 5.005;
use strict;
use Module::Install::Base;
use Carp ();
#line 16
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
$VERSION = '0.002';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
#line 42
sub author_tests {
my ($self, @dirs) = @_;
_add_author_tests($self, \@dirs, 0);
}
#line 56
sub recursive_author_tests {
my ($self, @dirs) = @_;
_add_author_tests($self, \@dirs, 1);
}
sub _wanted {
my $href = shift;
sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 }
}
sub _add_author_tests {
my ($self, $dirs, $recurse) = @_;
return unless $Module::Install::AUTHOR;
my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t';
# XXX: pick a default, later -- rjbs, 2008-02-24
my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests";
@dirs = grep { -d } @dirs;
if ($recurse) {
require File::Find;
my %test_dir;
File::Find::find(_wanted(\%test_dir), @dirs);
$self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir );
} else {
$self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs );
}
}
#line 107
1;
inc/Module/Install/Base.pm view on Meta::CPAN
#line 1
package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
$VERSION = '1.21';
}
# Suspend handler for "redefined" warnings
BEGIN {
my $w = $SIG{__WARN__};
$SIG{__WARN__} = sub { $w };
}
#line 42
sub new {
my $class = shift;
unless ( defined &{"${class}::call"} ) {
*{"${class}::call"} = sub { shift->_top->call(@_) };
}
unless ( defined &{"${class}::load"} ) {
*{"${class}::load"} = sub { shift->_top->load(@_) };
}
bless { @_ }, $class;
}
#line 61
sub AUTOLOAD {
local $@;
my $func = eval { shift->_top->autoload } or return;
goto &$func;
}
#line 75
sub _top {
$_[0]->{_top};
}
#line 90
sub admin {
$_[0]->_top->{admin}
or
Module::Install::Base::FakeAdmin->new;
}
#line 106
sub is_admin {
! $_[0]->admin->isa('Module::Install::Base::FakeAdmin');
}
sub DESTROY {}
package Module::Install::Base::FakeAdmin;
use vars qw{$VERSION};
BEGIN {
$VERSION = $Module::Install::Base::VERSION;
}
my $fake;
sub new {
$fake ||= bless(\@_, $_[0]);
}
sub AUTOLOAD {}
sub DESTROY {}
# Restore warning handler
BEGIN {
$SIG{__WARN__} = $SIG{__WARN__}->();
}
1;
#line 159
inc/Module/Install/Can.pm view on Meta::CPAN
#line 1
package Module::Install::Can;
use strict;
use Config ();
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.21';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
# check if we can load some module
### Upgrade this to not have to load the module if possible
sub can_use {
my ($self, $mod, $ver) = @_;
$mod =~ s{::|\\}{/}g;
$mod .= '.pm' unless $mod =~ /\.pm$/i;
my $pkg = $mod;
$pkg =~ s{/}{::}g;
$pkg =~ s{\.pm$}{}i;
local $@;
eval { require $mod; $pkg->VERSION($ver || 0); 1 };
}
# Check if we can run some command
sub can_run {
my ($self, $cmd) = @_;
my $_cmd = $cmd;
return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
next if $dir eq '';
require File::Spec;
my $abs = File::Spec->catfile($dir, $cmd);
return $abs if (-x $abs or $abs = MM->maybe_command($abs));
}
return;
}
# Can our C compiler environment build XS files
sub can_xs {
my $self = shift;
# Ensure we have the CBuilder module
$self->configure_requires( 'ExtUtils::CBuilder' => 0.27 );
# Do we have the configure_requires checker?
local $@;
eval "require ExtUtils::CBuilder;";
if ( $@ ) {
# They don't obey configure_requires, so it is
# someone old and delicate. Try to avoid hurting
# them by falling back to an older simpler test.
return $self->can_cc();
}
# Do we have a working C compiler
my $builder = ExtUtils::CBuilder->new(
quiet => 1,
);
unless ( $builder->have_compiler ) {
# No working C compiler
return 0;
}
# Write a C file representative of what XS becomes
require File::Temp;
my ( $FH, $tmpfile ) = File::Temp::tempfile(
"compilexs-XXXXX",
SUFFIX => '.c',
);
binmode $FH;
print $FH <<'END_C';
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
int main(int argc, char **argv) {
return 0;
}
int boot_sanexs() {
return 1;
}
END_C
close $FH;
# Can the C compiler access the same headers XS does
my @libs = ();
my $object = undef;
eval {
local $^W = 0;
$object = $builder->compile(
source => $tmpfile,
);
@libs = $builder->link(
objects => $object,
module_name => 'sanexs',
);
};
my $result = $@ ? 0 : 1;
# Clean up all the build files
foreach ( $tmpfile, $object, @libs ) {
next unless defined $_;
1 while unlink;
}
return $result;
}
# Can we locate a (the) C compiler
sub can_cc {
my $self = shift;
if ($^O eq 'VMS') {
require ExtUtils::CBuilder;
my $builder = ExtUtils::CBuilder->new(
quiet => 1,
);
return $builder->have_compiler;
}
my @chunks = split(/ /, $Config::Config{cc}) or return;
# $Config{cc} may contain args; try to find out the program part
while (@chunks) {
return $self->can_run("@chunks") || (pop(@chunks), next);
}
return;
}
# Fix Cygwin bug on maybe_command();
if ( $^O eq 'cygwin' ) {
require ExtUtils::MM_Cygwin;
require ExtUtils::MM_Win32;
if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
*ExtUtils::MM_Cygwin::maybe_command = sub {
my ($self, $file) = @_;
if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
ExtUtils::MM_Win32->maybe_command($file);
} else {
ExtUtils::MM_Unix->maybe_command($file);
}
}
}
}
1;
__END__
#line 245
inc/Module/Install/Fetch.pm view on Meta::CPAN
#line 1
package Module::Install::Fetch;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.21';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub get_file {
my ($self, %args) = @_;
my ($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
$args{url} = $args{ftp_url}
or (warn("LWP support unavailable!\n"), return);
($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
}
$|++;
print "Fetching '$file' from $host... ";
unless (eval { require Socket; Socket::inet_aton($host) }) {
warn "'$host' resolve failed!\n";
return;
}
return unless $scheme eq 'ftp' or $scheme eq 'http';
require Cwd;
my $dir = Cwd::getcwd();
chdir $args{local_dir} or return if exists $args{local_dir};
if (eval { require LWP::Simple; 1 }) {
LWP::Simple::mirror($args{url}, $file);
}
elsif (eval { require Net::FTP; 1 }) { eval {
# use Net::FTP to get past firewall
my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
$ftp->login("anonymous", 'anonymous@example.com');
$ftp->cwd($path);
$ftp->binary;
$ftp->get($file) or (warn("$!\n"), return);
$ftp->quit;
} }
elsif (my $ftp = $self->can_run('ftp')) { eval {
# no Net::FTP, fallback to ftp.exe
require FileHandle;
my $fh = FileHandle->new;
local $SIG{CHLD} = 'IGNORE';
unless ($fh->open("|$ftp -n")) {
warn "Couldn't open ftp: $!\n";
chdir $dir; return;
}
my @dialog = split(/\n/, <<"END_FTP");
open $host
user anonymous anonymous\@example.com
cd $path
binary
get $file $file
quit
END_FTP
foreach (@dialog) { $fh->print("$_\n") }
$fh->close;
} }
else {
warn "No working 'ftp' program available!\n";
chdir $dir; return;
}
unless (-f $file) {
warn "Fetching failed: $@\n";
chdir $dir; return;
}
return if exists $args{size} and -s $file != $args{size};
system($args{run}) if exists $args{run};
unlink($file) if $args{remove};
print(((!exists $args{check_for} or -e $args{check_for})
? "done!" : "failed! ($!)"), "\n");
chdir $dir; return !$?;
}
1;
inc/Module/Install/Makefile.pm view on Meta::CPAN
#line 1
package Module::Install::Makefile;
use strict 'vars';
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
use Fcntl qw/:flock :seek/;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.21';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub Makefile { $_[0] }
my %seen = ();
sub prompt {
shift;
# Infinite loop protection
my @c = caller();
if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
}
# In automated testing or non-interactive session, always use defaults
if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) {
local $ENV{PERL_MM_USE_DEFAULT} = 1;
goto &ExtUtils::MakeMaker::prompt;
} else {
goto &ExtUtils::MakeMaker::prompt;
}
}
# Store a cleaned up version of the MakeMaker version,
# since we need to behave differently in a variety of
# ways based on the MM version.
my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
# If we are passed a param, do a "newer than" comparison.
# Otherwise, just return the MakeMaker version.
sub makemaker {
( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
}
# Ripped from ExtUtils::MakeMaker 6.56, and slightly modified
# as we only need to know here whether the attribute is an array
# or a hash or something else (which may or may not be appendable).
my %makemaker_argtype = (
C => 'ARRAY',
CONFIG => 'ARRAY',
# CONFIGURE => 'CODE', # ignore
DIR => 'ARRAY',
DL_FUNCS => 'HASH',
DL_VARS => 'ARRAY',
EXCLUDE_EXT => 'ARRAY',
EXE_FILES => 'ARRAY',
FUNCLIST => 'ARRAY',
H => 'ARRAY',
IMPORTS => 'HASH',
INCLUDE_EXT => 'ARRAY',
LIBS => 'ARRAY', # ignore ''
MAN1PODS => 'HASH',
MAN3PODS => 'HASH',
META_ADD => 'HASH',
META_MERGE => 'HASH',
PL_FILES => 'HASH',
PM => 'HASH',
PMLIBDIRS => 'ARRAY',
PMLIBPARENTDIRS => 'ARRAY',
PREREQ_PM => 'HASH',
CONFIGURE_REQUIRES => 'HASH',
SKIP => 'ARRAY',
TYPEMAPS => 'ARRAY',
XS => 'HASH',
# VERSION => ['version',''], # ignore
# _KEEP_AFTER_FLUSH => '',
clean => 'HASH',
depend => 'HASH',
dist => 'HASH',
dynamic_lib=> 'HASH',
linkext => 'HASH',
macro => 'HASH',
postamble => 'HASH',
realclean => 'HASH',
test => 'HASH',
tool_autosplit => 'HASH',
# special cases where you can use makemaker_append
CCFLAGS => 'APPENDABLE',
DEFINE => 'APPENDABLE',
INC => 'APPENDABLE',
LDDLFLAGS => 'APPENDABLE',
LDFROM => 'APPENDABLE',
);
sub makemaker_args {
my ($self, %new_args) = @_;
my $args = ( $self->{makemaker_args} ||= {} );
foreach my $key (keys %new_args) {
if ($makemaker_argtype{$key}) {
if ($makemaker_argtype{$key} eq 'ARRAY') {
$args->{$key} = [] unless defined $args->{$key};
unless (ref $args->{$key} eq 'ARRAY') {
$args->{$key} = [$args->{$key}]
}
push @{$args->{$key}},
ref $new_args{$key} eq 'ARRAY'
? @{$new_args{$key}}
: $new_args{$key};
}
elsif ($makemaker_argtype{$key} eq 'HASH') {
$args->{$key} = {} unless defined $args->{$key};
foreach my $skey (keys %{ $new_args{$key} }) {
$args->{$key}{$skey} = $new_args{$key}{$skey};
}
}
elsif ($makemaker_argtype{$key} eq 'APPENDABLE') {
$self->makemaker_append($key => $new_args{$key});
}
}
else {
if (defined $args->{$key}) {
warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n};
}
$args->{$key} = $new_args{$key};
}
}
return $args;
}
# For mm args that take multiple space-separated args,
# append an argument to the current list.
sub makemaker_append {
my $self = shift;
my $name = shift;
my $args = $self->makemaker_args;
$args->{$name} = defined $args->{$name}
? join( ' ', $args->{$name}, @_ )
: join( ' ', @_ );
}
sub build_subdirs {
my $self = shift;
my $subdirs = $self->makemaker_args->{DIR} ||= [];
for my $subdir (@_) {
push @$subdirs, $subdir;
}
}
sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
%$clean = (
%$clean,
FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
);
}
sub realclean_files {
my $self = shift;
my $realclean = $self->makemaker_args->{realclean} ||= {};
%$realclean = (
%$realclean,
FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
);
}
sub libs {
my $self = shift;
my $libs = ref $_[0] ? shift : [ shift ];
$self->makemaker_args( LIBS => $libs );
}
sub inc {
my $self = shift;
$self->makemaker_args( INC => shift );
}
sub _wanted_t {
}
sub tests_recursive {
my $self = shift;
my $dir = shift || 't';
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
my %tests = map { $_ => 1 } split / /, ($self->tests || '');
require File::Find;
File::Find::find(
sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 },
$dir
);
$self->tests( join ' ', sort keys %tests );
}
sub write {
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
# Check the current Perl version
my $perl_version = $self->perl_version;
if ( $perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
}
# Make sure we have a new enough MakeMaker
require ExtUtils::MakeMaker;
if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
# This previous attempted to inherit the version of
# ExtUtils::MakeMaker in use by the module author, but this
# was found to be untenable as some authors build releases
# using future dev versions of EU:MM that nobody else has.
# Instead, #toolchain suggests we use 6.59 which is the most
# stable version on CPAN at time of writing and is, to quote
# ribasushi, "not terminally fucked, > and tested enough".
# TODO: We will now need to maintain this over time to push
# the version up as new versions are released.
$self->build_requires( 'ExtUtils::MakeMaker' => 6.59 );
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 );
} else {
# Allow legacy-compatibility with 5.005 by depending on the
# most recent EU:MM that supported 5.005.
$self->build_requires( 'ExtUtils::MakeMaker' => 6.36 );
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 );
}
# Generate the MakeMaker params
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
$args->{NAME} = $self->module_name || $self->name;
$args->{NAME} =~ s/-/::/g;
$args->{VERSION} = $self->version or die <<'EOT';
ERROR: Can't determine distribution version. Please specify it
explicitly via 'version' in Makefile.PL, or set a valid $VERSION
in a module, and provide its file path via 'version_from' (or
'all_from' if you prefer) in Makefile.PL.
EOT
if ( $self->tests ) {
my @tests = split ' ', $self->tests;
my %seen;
$args->{test} = {
TESTS => (join ' ', grep {!$seen{$_}++} @tests),
};
} elsif ( $Module::Install::ExtraTests::use_extratests ) {
# Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness.
# So, just ignore our xt tests here.
} elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
$args->{test} = {
TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
};
}
if ( $] >= 5.005 ) {
$args->{ABSTRACT} = $self->abstract;
$args->{AUTHOR} = join ', ', @{$self->author || []};
}
if ( $self->makemaker(6.10) ) {
$args->{NO_META} = 1;
#$args->{NO_MYMETA} = 1;
}
if ( $self->makemaker(6.17) and $self->sign ) {
$args->{SIGN} = 1;
}
unless ( $self->is_admin ) {
delete $args->{SIGN};
}
if ( $self->makemaker(6.31) and $self->license ) {
$args->{LICENSE} = $self->license;
}
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
map { @$_ } # flatten [module => version]
map { @$_ }
grep $_,
($self->requires)
);
# Remove any reference to perl, PREREQ_PM doesn't support it
delete $args->{PREREQ_PM}->{perl};
# Merge both kinds of requires into BUILD_REQUIRES
my $build_prereq = ($args->{BUILD_REQUIRES} ||= {});
%$build_prereq = ( %$build_prereq,
map { @$_ } # flatten [module => version]
map { @$_ }
grep $_,
($self->configure_requires, $self->build_requires)
);
# Remove any reference to perl, BUILD_REQUIRES doesn't support it
delete $args->{BUILD_REQUIRES}->{perl};
# Delete bundled dists from prereq_pm, add it to Makefile DIR
my $subdirs = ($args->{DIR} || []);
if ($self->bundles) {
my %processed;
foreach my $bundle (@{ $self->bundles }) {
my ($mod_name, $dist_dir) = @$bundle;
delete $prereq->{$mod_name};
$dist_dir = File::Basename::basename($dist_dir); # dir for building this module
if (not exists $processed{$dist_dir}) {
if (-d $dist_dir) {
# List as sub-directory to be processed by make
push @$subdirs, $dist_dir;
}
# Else do nothing: the module is already present on the system
$processed{$dist_dir} = undef;
}
}
}
unless ( $self->makemaker('6.55_03') ) {
%$prereq = (%$prereq,%$build_prereq);
delete $args->{BUILD_REQUIRES};
}
if ( my $perl_version = $self->perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
if ( $self->makemaker(6.48) ) {
$args->{MIN_PERL_VERSION} = $perl_version;
}
}
if ($self->installdirs) {
warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS};
$args->{INSTALLDIRS} = $self->installdirs;
}
my %args = map {
( $_ => $args->{$_} ) } grep {defined($args->{$_} )
} keys %$args;
my $user_preop = delete $args{dist}->{PREOP};
if ( my $preop = $self->admin->preop($user_preop) ) {
foreach my $key ( keys %$preop ) {
$args{dist}->{$key} = $preop->{$key};
}
}
my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
$self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
}
sub fix_up_makefile {
my $self = shift;
my $makefile_name = shift;
my $top_class = ref($self->_top) || '';
my $top_version = $self->_top->VERSION || '';
my $preamble = $self->preamble
? "# Preamble by $top_class $top_version\n"
. $self->preamble
: '';
my $postamble = "# Postamble by $top_class $top_version\n"
. ($self->postamble || '');
local *MAKEFILE;
open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
eval { flock MAKEFILE, LOCK_EX };
my $makefile = do { local $/; <MAKEFILE> };
$makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
$makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
$makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
$makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
$makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
# Module::Install will never be used to build the Core Perl
# Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
# PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
$makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
# XXX - This is currently unused; not sure if it breaks other MM-users
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
seek MAKEFILE, 0, SEEK_SET;
truncate MAKEFILE, 0;
print MAKEFILE "$preamble$makefile$postamble" or die $!;
close MAKEFILE or die $!;
1;
}
sub preamble {
my ($self, $text) = @_;
$self->{preamble} = $text . $self->{preamble} if defined $text;
$self->{preamble};
}
sub postamble {
my ($self, $text) = @_;
$self->{postamble} ||= $self->admin->postamble;
$self->{postamble} .= $text if defined $text;
$self->{postamble}
}
1;
__END__
#line 544
inc/Module/Install/Metadata.pm view on Meta::CPAN
#line 1
package Module::Install::Metadata;
use strict 'vars';
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.21';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
my @boolean_keys = qw{
sign
};
my @scalar_keys = qw{
name
module_name
abstract
version
distribution_type
tests
installdirs
};
my @tuple_keys = qw{
configure_requires
build_requires
requires
recommends
bundles
resources
};
my @resource_keys = qw{
homepage
bugtracker
repository
};
my @array_keys = qw{
keywords
author
};
*authors = \&author;
sub Meta { shift }
sub Meta_BooleanKeys { @boolean_keys }
sub Meta_ScalarKeys { @scalar_keys }
sub Meta_TupleKeys { @tuple_keys }
sub Meta_ResourceKeys { @resource_keys }
sub Meta_ArrayKeys { @array_keys }
foreach my $key ( @boolean_keys ) {
*$key = sub {
my $self = shift;
if ( defined wantarray and not @_ ) {
return $self->{values}->{$key};
}
$self->{values}->{$key} = ( @_ ? $_[0] : 1 );
return $self;
};
}
foreach my $key ( @scalar_keys ) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} if defined wantarray and !@_;
$self->{values}->{$key} = shift;
return $self;
};
}
foreach my $key ( @array_keys ) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} if defined wantarray and !@_;
$self->{values}->{$key} ||= [];
push @{$self->{values}->{$key}}, @_;
return $self;
};
}
foreach my $key ( @resource_keys ) {
*$key = sub {
my $self = shift;
unless ( @_ ) {
return () unless $self->{values}->{resources};
return map { $_->[1] }
grep { $_->[0] eq $key }
@{ $self->{values}->{resources} };
}
return $self->{values}->{resources}->{$key} unless @_;
my $uri = shift or die(
"Did not provide a value to $key()"
);
$self->resources( $key => $uri );
return 1;
};
}
foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} unless @_;
my @added;
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
push @added, [ $module, $version ];
}
push @{ $self->{values}->{$key} }, @added;
return map {@$_} @added;
};
}
# Resource handling
my %lc_resource = map { $_ => 1 } qw{
homepage
license
bugtracker
repository
};
sub resources {
my $self = shift;
while ( @_ ) {
my $name = shift or last;
my $value = shift or next;
if ( $name eq lc $name and ! $lc_resource{$name} ) {
die("Unsupported reserved lowercase resource '$name'");
}
$self->{values}->{resources} ||= [];
push @{ $self->{values}->{resources} }, [ $name, $value ];
}
$self->{values}->{resources};
}
# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
sub test_requires { shift->build_requires(@_) }
sub install_requires { shift->build_requires(@_) }
# Aliases for installdirs options
sub install_as_core { $_[0]->installdirs('perl') }
sub install_as_cpan { $_[0]->installdirs('site') }
sub install_as_site { $_[0]->installdirs('site') }
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub dynamic_config {
my $self = shift;
my $value = @_ ? shift : 1;
if ( $self->{values}->{dynamic_config} ) {
# Once dynamic we never change to static, for safety
return 0;
}
$self->{values}->{dynamic_config} = $value ? 1 : 0;
return 1;
}
# Convenience command
sub static_config {
shift->dynamic_config(0);
}
sub perl_version {
my $self = shift;
return $self->{values}->{perl_version} unless @_;
my $version = shift or die(
"Did not provide a value to perl_version()"
);
# Normalize the version
$version = $self->_perl_version($version);
# We don't support the really old versions
unless ( $version >= 5.005 ) {
die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
}
$self->{values}->{perl_version} = $version;
}
sub all_from {
my ( $self, $file ) = @_;
unless ( defined($file) ) {
my $name = $self->name or die(
"all_from called with no args without setting name() first"
);
$file = join('/', 'lib', split(/-/, $name)) . '.pm';
$file =~ s{.*/}{} unless -e $file;
unless ( -e $file ) {
die("all_from cannot find $file from $name");
}
}
unless ( -f $file ) {
die("The path '$file' does not exist, or is not a file");
}
$self->{values}{all_from} = $file;
# Some methods pull from POD instead of code.
# If there is a matching .pod, use that instead
my $pod = $file;
$pod =~ s/\.pm$/.pod/i;
$pod = $file unless -e $pod;
# Pull the different values
$self->name_from($file) unless $self->name;
$self->version_from($file) unless $self->version;
$self->perl_version_from($file) unless $self->perl_version;
$self->author_from($pod) unless @{$self->author || []};
$self->license_from($pod) unless $self->license;
$self->abstract_from($pod) unless $self->abstract;
return 1;
}
sub provides {
my $self = shift;
my $provides = ( $self->{values}->{provides} ||= {} );
%$provides = (%$provides, @_) if @_;
return $provides;
}
sub auto_provides {
my $self = shift;
return $self unless $self->is_admin;
unless (-e 'MANIFEST') {
warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
return $self;
}
# Avoid spurious warnings as we are not checking manifest here.
local $SIG{__WARN__} = sub {1};
require ExtUtils::Manifest;
local *ExtUtils::Manifest::manicheck = sub { return };
require Module::Build;
my $build = Module::Build->new(
dist_name => $self->name,
dist_version => $self->version,
license => $self->license,
);
$self->provides( %{ $build->find_dist_packages || {} } );
}
sub feature {
my $self = shift;
my $name = shift;
my $features = ( $self->{values}->{features} ||= [] );
my $mods;
if ( @_ == 1 and ref( $_[0] ) ) {
# The user used ->feature like ->features by passing in the second
# argument as a reference. Accomodate for that.
$mods = $_[0];
} else {
$mods = \@_;
}
my $count = 0;
push @$features, (
$name => [
map {
ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
} @$mods
]
);
return @$features;
}
sub features {
my $self = shift;
while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
$self->feature( $name, @$mods );
}
return $self->{values}->{features}
? @{ $self->{values}->{features} }
: ();
}
sub no_index {
my $self = shift;
my $type = shift;
push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
return $self->{values}->{no_index};
}
sub read {
my $self = shift;
$self->include_deps( 'YAML::Tiny', 0 );
require YAML::Tiny;
my $data = YAML::Tiny::LoadFile('META.yml');
# Call methods explicitly in case user has already set some values.
while ( my ( $key, $value ) = each %$data ) {
next unless $self->can($key);
if ( ref $value eq 'HASH' ) {
while ( my ( $module, $version ) = each %$value ) {
$self->can($key)->($self, $module => $version );
}
} else {
$self->can($key)->($self, $value);
}
}
return $self;
}
sub write {
my $self = shift;
return $self unless $self->is_admin;
$self->admin->write_meta;
return $self;
}
sub version_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->version( ExtUtils::MM_Unix->parse_version($file) );
# for version integrity check
$self->makemaker_args( VERSION_FROM => $file );
}
sub abstract_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->abstract(
bless(
{ DISTNAME => $self->name },
'ExtUtils::MM_Unix'
)->parse_abstract($file)
);
}
# Add both distribution and module name
sub name_from {
my ($self, $file) = @_;
if (
Module::Install::_read($file) =~ m/
^ \s*
package \s*
([\w:]+)
[\s|;]*
/ixms
) {
my ($name, $module_name) = ($1, $1);
$name =~ s{::}{-}g;
$self->name($name);
unless ( $self->module_name ) {
$self->module_name($module_name);
}
} else {
die("Cannot determine name from $file\n");
}
}
sub _extract_perl_version {
if (
$_[0] =~ m/
^\s*
(?:use|require) \s*
v?
([\d_\.]+)
\s* ;
/ixms
) {
my $perl_version = $1;
$perl_version =~ s{_}{}g;
return $perl_version;
} else {
return;
}
}
sub perl_version_from {
my $self = shift;
my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
if ($perl_version) {
$self->perl_version($perl_version);
} else {
warn "Cannot determine perl version info from $_[0]\n";
return;
}
}
sub author_from {
my $self = shift;
my $content = Module::Install::_read($_[0]);
if ($content =~ m/
=head \d \s+ (?:authors?)\b \s*
([^\n]*)
|
=head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
.*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
([^\n]*)
/ixms) {
my $author = $1 || $2;
# XXX: ugly but should work anyway...
if (eval "require Pod::Escapes; 1") {
# Pod::Escapes has a mapping table.
# It's in core of perl >= 5.9.3, and should be installed
# as one of the Pod::Simple's prereqs, which is a prereq
# of Pod::Text 3.x (see also below).
$author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
{
defined $2
? chr($2)
: defined $Pod::Escapes::Name2character_number{$1}
? chr($Pod::Escapes::Name2character_number{$1})
: do {
warn "Unknown escape: E<$1>";
"E<$1>";
};
}gex;
}
elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) {
# Pod::Text < 3.0 has yet another mapping table,
# though the table name of 2.x and 1.x are different.
# (1.x is in core of Perl < 5.6, 2.x is in core of
# Perl < 5.9.3)
my $mapping = ($Pod::Text::VERSION < 2)
? \%Pod::Text::HTML_Escapes
: \%Pod::Text::ESCAPES;
$author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
{
defined $2
? chr($2)
: defined $mapping->{$1}
? $mapping->{$1}
: do {
warn "Unknown escape: E<$1>";
"E<$1>";
};
}gex;
}
else {
$author =~ s{E<lt>}{<}g;
$author =~ s{E<gt>}{>}g;
}
$self->author($author);
} else {
warn "Cannot determine author info from $_[0]\n";
}
}
#Stolen from M::B
my %license_urls = (
perl => 'http://dev.perl.org/licenses/',
apache => 'http://apache.org/licenses/LICENSE-2.0',
artistic => 'http://opensource.org/licenses/artistic-license.php',
lgpl => 'http://opensource.org/licenses/lgpl-license.php',
bsd => 'http://opensource.org/licenses/bsd-license.php',
gpl => 'http://opensource.org/licenses/gpl-license.php',
gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
mit => 'http://opensource.org/licenses/mit-license.php',
mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
open_source => undef,
unrestricted => undef,
restrictive => undef,
unknown => undef,
# these are not actually allowed in meta-spec v1.4 but are left here for compatibility:
apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
);
sub license {
my $self = shift;
return $self->{values}->{license} unless @_;
my $license = shift or die(
'Did not provide a value to license()'
);
$license = __extract_license($license) || lc $license;
$self->{values}->{license} = $license;
# Automatically fill in license URLs
if ( $license_urls{$license} ) {
$self->resources( license => $license_urls{$license} );
}
return 1;
}
sub _extract_license {
my $pod = shift;
my $matched;
return __extract_license(
($matched) = $pod =~ m/
(=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?)
(=head \d.*|=cut.*|)\z
/xms
) || __extract_license(
($matched) = $pod =~ m/
(=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?)
(=head \d.*|=cut.*|)\z
/xms
);
}
sub __extract_license {
my $license_text = shift or return;
my @phrases = (
'(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1,
'(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
'Artistic and GPL' => 'perl', 1,
'GNU general public license' => 'gpl', 1,
'GNU public license' => 'gpl', 1,
'GNU lesser general public license' => 'lgpl', 1,
'GNU lesser public license' => 'lgpl', 1,
'GNU library general public license' => 'lgpl', 1,
'GNU library public license' => 'lgpl', 1,
'GNU Free Documentation license' => 'unrestricted', 1,
'GNU Affero General Public License' => 'open_source', 1,
'(?:Free)?BSD license' => 'bsd', 1,
'Artistic license 2\.0' => 'artistic_2', 1,
'Artistic license' => 'artistic', 1,
'Apache (?:Software )?license' => 'apache', 1,
'GPL' => 'gpl', 1,
'LGPL' => 'lgpl', 1,
'BSD' => 'bsd', 1,
'Artistic' => 'artistic', 1,
'MIT' => 'mit', 1,
'Mozilla Public License' => 'mozilla', 1,
'Q Public License' => 'open_source', 1,
'OpenSSL License' => 'unrestricted', 1,
'SSLeay License' => 'unrestricted', 1,
'zlib License' => 'open_source', 1,
'proprietary' => 'proprietary', 0,
);
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
$pattern =~ s#\s+#\\s+#gs;
if ( $license_text =~ /\b$pattern\b/i ) {
return $license;
}
}
return '';
}
sub license_from {
my $self = shift;
if (my $license=_extract_license(Module::Install::_read($_[0]))) {
$self->license($license);
} else {
warn "Cannot determine license info from $_[0]\n";
return 'unknown';
}
}
sub _extract_bugtracker {
my @links = $_[0] =~ m#L<(
https?\Q://rt.cpan.org/\E[^>]+|
https?\Q://github.com/\E[\w_]+/[\w_]+/issues|
https?\Q://code.google.com/p/\E[\w_\-]+/issues/list
)>#gx;
my %links;
@links{@links}=();
@links=keys %links;
return @links;
}
sub bugtracker_from {
my $self = shift;
my $content = Module::Install::_read($_[0]);
my @links = _extract_bugtracker($content);
unless ( @links ) {
warn "Cannot determine bugtracker info from $_[0]\n";
return 0;
}
if ( @links > 1 ) {
warn "Found more than one bugtracker link in $_[0]\n";
return 0;
}
# Set the bugtracker
bugtracker( $links[0] );
return 1;
}
sub requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
$self->requires( $module => $version );
}
}
sub test_requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
$self->test_requires( $module => $version );
}
}
# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
# numbers (eg, 5.006001 or 5.008009).
# Also, convert double-part versions (eg, 5.8)
sub _perl_version {
my $v = $_[-1];
$v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
$v =~ s/(\.\d\d\d)000$/$1/;
$v =~ s/_.+$//;
if ( ref($v) ) {
# Numify
$v = $v + 0;
}
return $v;
}
sub add_metadata {
my $self = shift;
my %hash = @_;
for my $key (keys %hash) {
warn "add_metadata: $key is not prefixed with 'x_'.\n" .
"Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/;
$self->{values}->{$key} = $hash{$key};
}
}
######################################################################
# MYMETA Support
sub WriteMyMeta {
die "WriteMyMeta has been deprecated";
}
sub write_mymeta_yaml {
my $self = shift;
# We need YAML::Tiny to write the MYMETA.yml file
unless ( eval { require YAML::Tiny; 1; } ) {
return 1;
}
# Generate the data
my $meta = $self->_write_mymeta_data or return 1;
# Save as the MYMETA.yml file
print "Writing MYMETA.yml\n";
YAML::Tiny::DumpFile('MYMETA.yml', $meta);
}
sub write_mymeta_json {
my $self = shift;
# We need JSON to write the MYMETA.json file
unless ( eval { require JSON; 1; } ) {
return 1;
}
# Generate the data
my $meta = $self->_write_mymeta_data or return 1;
# Save as the MYMETA.yml file
print "Writing MYMETA.json\n";
Module::Install::_write(
'MYMETA.json',
JSON->new->pretty(1)->canonical->encode($meta),
);
}
sub _write_mymeta_data {
my $self = shift;
# If there's no existing META.yml there is nothing we can do
return undef unless -f 'META.yml';
# We need Parse::CPAN::Meta to load the file
unless ( eval { require Parse::CPAN::Meta; 1; } ) {
return undef;
}
# Merge the perl version into the dependencies
my $val = $self->Meta->{values};
my $perl = delete $val->{perl_version};
if ( $perl ) {
$val->{requires} ||= [];
my $requires = $val->{requires};
# Canonize to three-dot version after Perl 5.6
if ( $perl >= 5.006 ) {
$perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
}
unshift @$requires, [ perl => $perl ];
}
# Load the advisory META.yml file
my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
my $meta = $yaml[0];
# Overwrite the non-configure dependency hashes
delete $meta->{requires};
delete $meta->{build_requires};
delete $meta->{recommends};
if ( exists $val->{requires} ) {
$meta->{requires} = { map { @$_ } @{ $val->{requires} } };
}
if ( exists $val->{build_requires} ) {
$meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
}
return $meta;
}
1;
inc/Module/Install/ReadmeFromPod.pm view on Meta::CPAN
#line 1
package Module::Install::ReadmeFromPod;
use 5.006;
use strict;
use warnings;
use base qw(Module::Install::Base);
use vars qw($VERSION);
$VERSION = '0.30';
{
# these aren't defined until after _require_admin is run, so
# define them so prototypes are available during compilation.
sub io;
sub capture(&;@);
#line 28
my $done = 0;
sub _require_admin {
# do this once to avoid redefinition warnings from IO::All
return if $done;
require IO::All;
IO::All->import( '-binary' );
require Capture::Tiny;
Capture::Tiny->import ( 'capture' );
return;
}
}
sub readme_from {
my $self = shift;
return unless $self->is_admin;
_require_admin;
# Input file
my $in_file = shift || $self->_all_from
or die "Can't determine file to make readme_from";
# Get optional arguments
my ($clean, $format, $out_file, $options);
my $args = shift;
if ( ref $args ) {
# Arguments are in a hashref
if ( ref($args) ne 'HASH' ) {
die "Expected a hashref but got a ".ref($args)."\n";
} else {
$clean = $args->{'clean'};
$format = $args->{'format'};
$out_file = $args->{'output_file'};
$options = $args->{'options'};
}
} else {
# Arguments are in a list
$clean = $args;
$format = shift;
$out_file = shift;
$options = \@_;
}
# Default values;
$clean ||= 0;
$format ||= 'txt';
# Generate README
print "readme_from $in_file to $format\n";
if ($format =~ m/te?xt/) {
$out_file = $self->_readme_txt($in_file, $out_file, $options);
} elsif ($format =~ m/html?/) {
$out_file = $self->_readme_htm($in_file, $out_file, $options);
} elsif ($format eq 'man') {
$out_file = $self->_readme_man($in_file, $out_file, $options);
} elsif ($format eq 'md') {
$out_file = $self->_readme_md($in_file, $out_file, $options);
} elsif ($format eq 'pdf') {
$out_file = $self->_readme_pdf($in_file, $out_file, $options);
}
if ($clean) {
$self->clean_files($out_file);
}
return 1;
}
sub _readme_txt {
my ($self, $in_file, $out_file, $options) = @_;
$out_file ||= 'README';
require Pod::Text;
my $parser = Pod::Text->new( @$options );
my $io = io->file($out_file)->open(">");
my $out_fh = $io->io_handle;
$parser->output_fh( *$out_fh );
$parser->parse_file( $in_file );
return $out_file;
}
sub _readme_htm {
my ($self, $in_file, $out_file, $options) = @_;
$out_file ||= 'README.htm';
require Pod::Html;
my ($o) = capture {
Pod::Html::pod2html(
"--infile=$in_file",
"--outfile=-",
@$options,
);
};
io->file($out_file)->print($o);
# Remove temporary files if needed
for my $file ('pod2htmd.tmp', 'pod2htmi.tmp') {
if (-e $file) {
unlink $file or warn "Warning: Could not remove file '$file'.\n$!\n";
}
}
return $out_file;
}
sub _readme_man {
my ($self, $in_file, $out_file, $options) = @_;
$out_file ||= 'README.1';
require Pod::Man;
my $parser = Pod::Man->new( @$options );
my $io = io->file($out_file)->open(">");
my $out_fh = $io->io_handle;
$parser->output_fh( *$out_fh );
$parser->parse_file( $in_file );
return $out_file;
}
sub _readme_pdf {
my ($self, $in_file, $out_file, $options) = @_;
$out_file ||= 'README.pdf';
eval { require App::pod2pdf; }
or die "Could not generate $out_file because pod2pdf could not be found\n";
my $parser = App::pod2pdf->new( @$options );
$parser->parse_from_file($in_file);
my ($o) = capture { $parser->output };
io->file($out_file)->print($o);
return $out_file;
}
sub _readme_md {
my ($self, $in_file, $out_file, $options) = @_;
$out_file ||= 'README.md';
require Pod::Markdown;
my $parser = Pod::Markdown->new( @$options );
my $io = io->file($out_file)->open(">");
my $out_fh = $io->io_handle;
$parser->output_fh( *$out_fh );
$parser->parse_file( $in_file );
return $out_file;
}
sub _all_from {
my $self = shift;
return unless $self->admin->{extensions};
my ($metadata) = grep {
ref($_) eq 'Module::Install::Metadata';
} @{$self->admin->{extensions}};
return unless $metadata;
return $metadata->{values}{all_from} || '';
}
'Readme!';
__END__
#line 316
inc/Module/Install/Win32.pm view on Meta::CPAN
#line 1
package Module::Install::Win32;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.21';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
# determine if the user needs nmake, and download it if needed
sub check_nmake {
my $self = shift;
$self->load('can_run');
$self->load('get_file');
require Config;
return unless (
$^O eq 'MSWin32' and
$Config::Config{make} and
$Config::Config{make} =~ /^nmake\b/i and
! $self->can_run('nmake')
);
print "The required 'nmake' executable not found, fetching it...\n";
require File::Basename;
my $rv = $self->get_file(
url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
local_dir => File::Basename::dirname($^X),
size => 51928,
run => 'Nmake15.exe /o > nul',
check_for => 'Nmake.exe',
remove => 1,
);
die <<'END_MESSAGE' unless $rv;
-------------------------------------------------------------------------------
Since you are using Microsoft Windows, you will need the 'nmake' utility
before installation. It's available at:
http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
or
ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
Please download the file manually, save it to a directory in %PATH% (e.g.
C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
that directory, and run "Nmake15.exe" from there; that will create the
'nmake.exe' file needed by this module.
You may then resume the installation process described in README.
-------------------------------------------------------------------------------
END_MESSAGE
}
1;
inc/Module/Install/WriteAll.pm view on Meta::CPAN
#line 1
package Module::Install::WriteAll;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.21';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
sub WriteAll {
my $self = shift;
my %args = (
meta => 1,
sign => 0,
inline => 0,
check_nmake => 1,
@_,
);
$self->sign(1) if $args{sign};
$self->admin->WriteAll(%args) if $self->is_admin;
$self->check_nmake if $args{check_nmake};
unless ( $self->makemaker_args->{PL_FILES} ) {
# XXX: This still may be a bit over-defensive...
unless ($self->makemaker(6.25)) {
$self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL';
}
}
# Until ExtUtils::MakeMaker support MYMETA.yml, make sure
# we clean it up properly ourself.
$self->realclean_files('MYMETA.yml');
if ( $args{inline} ) {
$self->Inline->write;
} else {
$self->Makefile->write;
}
# The Makefile write process adds a couple of dependencies,
# so write the META.yml files after the Makefile.
if ( $args{meta} ) {
$self->Meta->write;
}
# Experimental support for MYMETA
if ( $ENV{X_MYMETA} ) {
if ( $ENV{X_MYMETA} eq 'JSON' ) {
$self->Meta->write_mymeta_json;
} else {
$self->Meta->write_mymeta_yaml;
}
}
return 1;
}
1;
t/PYX-XMLSchema-List/01-use.t view on Meta::CPAN
use strict;
use warnings;
use Test::More 'tests' => 3;
use Test::NoWarnings;
BEGIN {
# Test.
use_ok('PYX::XMLSchema::List');
}
# Test.
require_ok('PYX::XMLSchema::List');
t/PYX-XMLSchema-List/02-version.t view on Meta::CPAN
use strict;
use warnings;
use PYX::XMLSchema::List;
use Test::More 'tests' => 2;
use Test::NoWarnings;
# Test.
is($PYX::XMLSchema::List::VERSION, 0.06, 'Version.');
t/PYX-XMLSchema-List/03-new.t view on Meta::CPAN
use strict;
use warnings;
use English qw(-no_match_vars);
use Error::Pure::Utils qw(clean);
use PYX::XMLSchema::List;
use Test::More 'tests' => 4;
use Test::NoWarnings;
# Test.
eval {
PYX::XMLSchema::List->new('');
};
is($EVAL_ERROR, "Unknown parameter ''.\n",
"Unknown parameter ''.");
clean();
# Test.
eval {
PYX::XMLSchema::List->new(
'something' => 'value',
);
};
is($EVAL_ERROR, "Unknown parameter 'something'.\n",
"Unknown parameter 'something'.");
clean();
# Test.
my $obj = PYX::XMLSchema::List->new;
isa_ok($obj, 'PYX::XMLSchema::List');
t/PYX-XMLSchema-List/04-parse.t view on Meta::CPAN
use strict;
use warnings;
use File::Object;
use PYX::XMLSchema::List;
use Perl6::Slurp qw(slurp);
use Test::More 'tests' => 4;
use Test::NoWarnings;
use Test::Output;
# Directories.
my $data_dir = File::Object->new->up->dir('data');
# Test.
my $obj = PYX::XMLSchema::List->new;
my $pyx_data = slurp($data_dir->file('ex1.pyx')->s);
my $right_ret = <<"END";
No XML schemas.
END
stdout_is(
sub {
$obj->parse($pyx_data);
return;
},
$right_ret,
'Parse data from ex1.pyx file.',
);
# Test.
$right_ret = <<'END';
[ bar ] (E: 0000, A: 0001) http://bar.foo
[ fo ] (E: 0001, A: 0001) http://foo.bar
[ xml ] (E: 0000, A: 0001)
END
$pyx_data = slurp($data_dir->file('ex2.pyx')->s);
stdout_is(
sub {
$obj->parse($pyx_data);
return;
},
$right_ret,
'Parse data from ex2.pyx file.',
);
$obj->reset;
# Test.
$right_ret = <<'END';
[ foo ] (E: 0001, A: 0000) http://foo
END
$pyx_data = slurp($data_dir->file('ex3.pyx')->s);
stdout_is(
sub {
$obj->parse($pyx_data);
return;
},
$right_ret,
'Parse data from ex3.pyx file.',
);
$obj->reset;
t/PYX-XMLSchema-List/05-parse_file.t view on Meta::CPAN
use strict;
use warnings;
use File::Object;
use PYX::XMLSchema::List;
use Test::More 'tests' => 4;
use Test::NoWarnings;
use Test::Output;
# Directories.
my $data_dir = File::Object->new->up->dir('data');
# Test.
my $obj = PYX::XMLSchema::List->new;
my $right_ret = <<"END";
No XML schemas.
END
stdout_is(
sub {
$obj->parse_file($data_dir->file('ex1.pyx')->s);
return;
},
$right_ret,
'Parse ex1.pyx file.',
);
# Test.
$right_ret = <<'END';
[ bar ] (E: 0000, A: 0001) http://bar.foo
[ fo ] (E: 0001, A: 0001) http://foo.bar
[ xml ] (E: 0000, A: 0001)
END
stdout_is(
sub {
$obj->parse_file($data_dir->file('ex2.pyx')->s);
return;
},
$right_ret,
'Parse ex2.pyx file.',
);
$obj->reset;
# Test.
$right_ret = <<'END';
[ foo ] (E: 0001, A: 0000) http://foo
END
stdout_is(
sub {
$obj->parse_file($data_dir->file('ex3.pyx')->s);
return;
},
$right_ret,
'Parse ex3.pyx file.',
);
$obj->reset;
t/PYX-XMLSchema-List/06-parse_handler.t view on Meta::CPAN
use strict;
use warnings;
use File::Object;
use PYX::XMLSchema::List;
use Test::More 'tests' => 4;
use Test::NoWarnings;
use Test::Output;
# Directories.
my $data_dir = File::Object->new->up->dir('data');
# Test.
my $obj = PYX::XMLSchema::List->new;
my $right_ret = <<"END";
No XML schemas.
END
open my $pyx_handler, '<', $data_dir->file('ex1.pyx')->s;
stdout_is(
sub {
$obj->parse_handler($pyx_handler);
return;
},
$right_ret,
'Parse ex1.pyx file handler.',
);
close $pyx_handler;
# Test.
$right_ret = <<'END';
[ bar ] (E: 0000, A: 0001) http://bar.foo
[ fo ] (E: 0001, A: 0001) http://foo.bar
[ xml ] (E: 0000, A: 0001)
END
open $pyx_handler, '<', $data_dir->file('ex2.pyx')->s;
stdout_is(
sub {
$obj->parse_handler($pyx_handler);
return;
},
$right_ret,
'Parse ex2.pyx file handler.',
);
close $pyx_handler;
$obj->reset;
# Test.
$right_ret = <<'END';
[ foo ] (E: 0001, A: 0000) http://foo
END
open $pyx_handler, '<', $data_dir->file('ex3.pyx')->s;
stdout_is(
sub {
$obj->parse_handler($pyx_handler);
return;
},
$right_ret,
'Parse ex3.pyx file handler.',
);
close $pyx_handler;
$obj->reset;
t/PYX-XMLSchema-List/07-reset.t view on Meta::CPAN
use strict;
use warnings;
use File::Object;
use PYX::XMLSchema::List;
use Test::More 'tests' => 3;
use Test::NoWarnings;
use Test::Output;
# Directories.
my $data_dir = File::Object->new->up->dir('data');
# Test.
my $obj = PYX::XMLSchema::List->new;
my $right_ret = <<'END';
[ bar ] (E: 0000, A: 0001) http://bar.foo
[ fo ] (E: 0001, A: 0001) http://foo.bar
[ xml ] (E: 0000, A: 0001)
END
open my $pyx_handler, '<', $data_dir->file('ex2.pyx')->s;
stdout_is(
sub {
$obj->parse_handler($pyx_handler);
return;
},
$right_ret,
'Parse ex2.pyx file handler.',
);
$obj->reset;
my $ret = $obj->stats;
is_deeply(
$ret,
{},
'Get statistics after reset of ex2.pyx statistics.',
);
t/PYX-XMLSchema-List/08-stats.t view on Meta::CPAN
use strict;
use warnings;
use File::Object;
use PYX::XMLSchema::List;
use Test::More 'tests' => 3;
use Test::NoWarnings;
use Test::Output;
# Directories.
my $data_dir = File::Object->new->up->dir('data');
# Test.
my $obj = PYX::XMLSchema::List->new;
my $right_ret = <<'END';
[ bar ] (E: 0000, A: 0001) http://bar.foo
[ fo ] (E: 0001, A: 0001) http://foo.bar
[ xml ] (E: 0000, A: 0001)
END
open my $pyx_handler, '<', $data_dir->file('ex2.pyx')->s;
stdout_is(
sub {
$obj->parse_handler($pyx_handler);
return;
},
$right_ret,
'Parse ex2.pyx file handler.',
);
my $ret = $obj->stats;
is_deeply(
$ret,
{
'fo' => ['http://foo.bar', {
'attr' => 1,
'element' => 1,
}],
'bar' => ['http://bar.foo', {
'attr' => 1,
'element' => 0,
}],
'xml' => ['', {
'attr' => 1,
'element' => 0,
}],
},
'Get statistics for ex2.pyx file.',
);
$obj->reset;
t/data/ex1.pyx view on Meta::CPAN
(tag
Aattr1 value
Aattr2 value
Aattr3 value
-text
)tag
t/data/ex2.pyx view on Meta::CPAN
(foo
Axmlns:bar http://bar.foo
Axmlns:fo http://foo.bar
Afo:bar baz
(fo:bar
Axml:lang en
Abar:foo baz
)fo:bar
)foo
( run in 0.641 second using v1.01-cache-2.11-cpan-7add2cbd662 )