[Bps-public-commit] Text-Quoted branch, master, updated. 391817889e0b8e10237aa0371a3b19f379169cde
Ruslan Zakirov
ruz at bestpractical.com
Mon Mar 15 13:37:50 EDT 2010
The branch, master has been updated
via 391817889e0b8e10237aa0371a3b19f379169cde (commit)
via ef021d3827a2d7c57370555aa925640f7449dc74 (commit)
via 9cc59a1a40c6bc8e19f8125c1d6e011ae47e15c6 (commit)
via b09033ff84653aec5d60f491b14011cf6a07a21f (commit)
via 050678296cdc1b8edf9b8e8022e212d789731387 (commit)
via 5d82be1240f11138f611ea6e14bf0d6887d59fe5 (commit)
via 8d7b32ff45d432d8fa176b5c47f0b7ff515c4c54 (commit)
via 6fe4ed1a58819aacc8c2f0d1366fae2642b7d4bc (commit)
via 90340d6f8972dd9c46179ba969aa17bd0e7becbd (commit)
via be5dbfff84334f41fc4e281ae6160eaafee9f8e2 (commit)
via 4cd45f3446c5d25019ccaf2fecc82d5b8c1ac76f (commit)
via 33b9d87b81ddb86732e384f0aec855c73dae369e (commit)
via b4dcd35ed246f4c8095f8f0741fbecf4880311ae (commit)
via 426f5ac2048c6762ba94d4108205e9b93c605aac (commit)
via 7721b931b1edd3cc9429a46117d0acc9663bb8cb (commit)
via f34abdc408a79339427a37c83079331302c84764 (commit)
via 9949e45f9fb626d40166bfeed43f9dadcb2fb5f9 (commit)
from 207da345f3bfabc36e07136d882ae1d9cc3534ad (commit)
Summary of changes:
.gitignore | 5 +
Changes | 8 +
MANIFEST | 14 +-
META.yml | 30 +-
Quoted.pm | 31 +-
inc/Module/Install.pm | 532 ++++++++++++++++---------
inc/Module/Install/Base.pm | 60 ++--
inc/Module/Install/Can.pm | 21 +-
inc/Module/Install/Fetch.pm | 12 +-
inc/Module/Install/Makefile.pm | 144 +++++--
inc/Module/Install/Metadata.pm | 832 ++++++++++++++++++++++++++------------
inc/Module/Install/Win32.pm | 15 +-
inc/Module/Install/WriteAll.pm | 77 +++--
t/1.t | 60 ---
t/6.t | 101 -----
t/basics.t | 150 +++++++
t/{5.t => empty_text.t} | 5 +-
t/{7.t => expand_tab_segfault.t} | 1 -
t/{2.t => life_sample.1.t} | 9 +-
t/{3.t => life_sample.2.t} | 7 -
t/{4.t => life_sample.3.t} | 0
t/separator.t | 44 ++
22 files changed, 1381 insertions(+), 777 deletions(-)
create mode 100644 .gitignore
delete mode 100644 t/1.t
delete mode 100644 t/6.t
create mode 100644 t/basics.t
rename t/{5.t => empty_text.t} (83%)
rename t/{7.t => expand_tab_segfault.t} (95%)
rename t/{2.t => life_sample.1.t} (95%)
rename t/{3.t => life_sample.2.t} (93%)
rename t/{4.t => life_sample.3.t} (100%)
create mode 100644 t/separator.t
- Log -----------------------------------------------------------------
commit 9949e45f9fb626d40166bfeed43f9dadcb2fb5f9
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Mar 15 13:11:38 2010 +0300
.gitignore
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..508fefb
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,4 @@
+Makefile
+pm_to_blib
+blib/
+MANIFEST.old
commit f34abdc408a79339427a37c83079331302c84764
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Mar 15 13:12:12 2010 +0300
add test for separators
diff --git a/t/separator.t b/t/separator.t
new file mode 100644
index 0000000..ecae994
--- /dev/null
+++ b/t/separator.t
@@ -0,0 +1,24 @@
+
+use Test::More tests => 3;
+BEGIN { use_ok('Text::Quoted') };
+
+use Data::Dumper;
+
+my $text = <<EOF;
+foo
+============
+bar
+============
+baz
+EOF
+
+is_deeply(extract($text), [
+ {text => 'foo', empty => '', quoter => '', raw => 'foo'},
+ {text => '============', empty => '', quoter => '', raw => '============', separator => 1 },
+ {text => 'bar', empty => '', quoter => '', raw => 'bar'},
+ {text => '============', empty => '', quoter => '', raw => '============', separator => 1 },
+ {text => 'baz', empty => '', quoter => '', raw => 'baz'},
+ ],
+ "Sample text is organized properly"
+) or diag Dumper(extract($text));
+
commit 7721b931b1edd3cc9429a46117d0acc9663bb8cb
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Mar 15 13:31:54 2010 +0300
don't mark string as quoted if it's a separator
diff --git a/Quoted.pm b/Quoted.pm
index 1e44bbe..bd3d7b3 100644
--- a/Quoted.pm
+++ b/Quoted.pm
@@ -173,7 +173,7 @@ sub classify {
# PARSE EACH LINE
foreach (splice @lines) {
my %line = ( raw => $_ );
- @line{'quoter', 'text'} = (/\A *($quoter?) *(.*?)\s*\Z/o);
+ @line{'quoter', 'text'} = (/\A *((?:(?!$separator\s*\Z)$quoter)?) *(.*?)\s*\Z/o);
$line{hang} = Hang->new( $line{'text'} );
$line{empty} = $line{hang}->empty() && $line{'text'} !~ /\S/;
$line{separator} = $line{text} =~ /^$separator$/o;
commit 426f5ac2048c6762ba94d4108205e9b93c605aac
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Mar 15 13:37:54 2010 +0300
refactor code a litle with return format minor change
* don't set boolean if those are false
* return separator key if a string is a separator
* less operations
diff --git a/Quoted.pm b/Quoted.pm
index bd3d7b3..8f093dc 100644
--- a/Quoted.pm
+++ b/Quoted.pm
@@ -59,14 +59,7 @@ is the quotation string.
=cut
sub extract {
- return organize( "",
- map +{
- raw => $_->{'raw'},
- empty => $_->{'empty'},
- text => $_->{'text'},
- quoter => $_->{'quoter'},
- }, classify( @_ )
- );
+ return organize( "", classify( @_ ) );
}
=head1 CREDITS
@@ -175,8 +168,8 @@ sub classify {
my %line = ( raw => $_ );
@line{'quoter', 'text'} = (/\A *((?:(?!$separator\s*\Z)$quoter)?) *(.*?)\s*\Z/o);
$line{hang} = Hang->new( $line{'text'} );
- $line{empty} = $line{hang}->empty() && $line{'text'} !~ /\S/;
- $line{separator} = $line{text} =~ /^$separator$/o;
+ $line{empty} = 1 if $line{hang}->empty() && $line{'text'} !~ /\S/;
+ $line{separator} = 1 if $line{text} =~ /\A *$separator *\Z/o;
push @lines, \%line;
}
@@ -223,8 +216,8 @@ sub classify {
}
# Reapply hangs
- for (grep $_->{hang}, @paras) {
- next unless my $str = $_->{hang}->stringify;
+ for (grep $_->{'hang'}, @paras) {
+ next unless my $str = (delete $_->{hang})->stringify;
$_->{text} = $str . " " . $_->{text};
}
return @paras;
commit b4dcd35ed246f4c8095f8f0741fbecf4880311ae
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Mar 15 19:18:43 2010 +0300
test with quoted separator
diff --git a/t/separator.t b/t/separator.t
index ecae994..1e347e8 100644
--- a/t/separator.t
+++ b/t/separator.t
@@ -13,11 +13,31 @@ baz
EOF
is_deeply(extract($text), [
- {text => 'foo', empty => '', quoter => '', raw => 'foo'},
- {text => '============', empty => '', quoter => '', raw => '============', separator => 1 },
- {text => 'bar', empty => '', quoter => '', raw => 'bar'},
- {text => '============', empty => '', quoter => '', raw => '============', separator => 1 },
- {text => 'baz', empty => '', quoter => '', raw => 'baz'},
+ {text => 'foo', quoter => '', raw => 'foo'},
+ {text => '============', quoter => '', raw => '============', separator => 1 },
+ {text => 'bar', quoter => '', raw => 'bar'},
+ {text => '============', quoter => '', raw => '============', separator => 1 },
+ {text => 'baz', quoter => '', raw => 'baz'},
+ ],
+ "Sample text is organized properly"
+) or diag Dumper(extract($text));
+
+$text = <<EOF;
+foo
+> bar
+> ============
+> baz
+> ============
+EOF
+
+is_deeply(extract($text), [
+ {text => 'foo', quoter => '', raw => 'foo'},
+ [
+ {text => 'bar', quoter => '>', raw => '> bar'},
+ {text => '============', quoter => '>', raw => '> ============', separator => 1 },
+ {text => 'baz', quoter => '>', raw => '> baz'},
+ {text => '============', quoter => '>', raw => '> ============', separator => 1 },
+ ],
],
"Sample text is organized properly"
) or diag Dumper(extract($text));
commit 33b9d87b81ddb86732e384f0aec855c73dae369e
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Mar 15 19:19:54 2010 +0300
fix situations when seprator is quoted
diff --git a/Quoted.pm b/Quoted.pm
index 8f093dc..5316863 100644
--- a/Quoted.pm
+++ b/Quoted.pm
@@ -147,11 +147,10 @@ sub find_below {
# BITS OF A TEXT LINE
-my $quotechar = qq{[!#%=|:]};
-my $quotechunk = qq{(?:$quotechar(?!\\w)|\\w*>+)};
-my $quoter = qq{(?:(?i)(?:$quotechunk(?:[ \\t]*$quotechunk)*))};
-
-my $separator = q/(?:[-_]{2,}|[=#*]{3,}|[+~]{4,})/;
+my $quotechar = qr/[!#%=|:]/;
+my $separator = qr/[-_]{2,} | [=#*]{3,} | [+~]{4,}/x;
+my $quotechunk = qr/(?!$separator *\z)(?:$quotechar(?!\w)|\w*>+)/;
+my $quoter = qr/$quotechunk(?:[ \t]*$quotechunk)*/;
sub defn($) { return $_[0] if (defined $_[0]); return "" }
@@ -166,7 +165,7 @@ sub classify {
# PARSE EACH LINE
foreach (splice @lines) {
my %line = ( raw => $_ );
- @line{'quoter', 'text'} = (/\A *((?:(?!$separator\s*\Z)$quoter)?) *(.*?)\s*\Z/o);
+ @line{'quoter', 'text'} = (/\A *($quoter?) *(.*?)\s*\Z/o);
$line{hang} = Hang->new( $line{'text'} );
$line{empty} = 1 if $line{hang}->empty() && $line{'text'} !~ /\S/;
$line{separator} = 1 if $line{text} =~ /\A *$separator *\Z/o;
commit 4cd45f3446c5d25019ccaf2fecc82d5b8c1ac76f
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Mar 15 19:20:24 2010 +0300
handle empty strings asap
diff --git a/Quoted.pm b/Quoted.pm
index 5316863..0ab4fc3 100644
--- a/Quoted.pm
+++ b/Quoted.pm
@@ -156,7 +156,8 @@ sub defn($) { return $_[0] if (defined $_[0]); return "" }
sub classify {
my $text = shift;
- $text = "" unless defined $text;
+ return { raw => undef, text => undef, quoter => undef }
+ unless defined $text && length $text;
# If the user passes in a null string, we really want to end up with _something_
# DETABIFY
commit be5dbfff84334f41fc4e281ae6160eaafee9f8e2
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Mar 15 19:21:00 2010 +0300
update tests as we don't announce "empty => ''"
diff --git a/t/1.t b/t/1.t
index a8cd0f1..a263d73 100644
--- a/t/1.t
+++ b/t/1.t
@@ -22,12 +22,12 @@ quux
EOF
is_deeply(extract($a),
-[[{text => 'foo',empty => '',quoter => '>',raw => '> foo'},
- [{text => 'Bar',empty => '',quoter => '> #',raw => '> # Bar'}],
- {text => 'baz',empty => '',quoter => '>',raw => '> baz'}
+[[{text => 'foo',quoter => '>',raw => '> foo'},
+ [{text => 'Bar',quoter => '> #',raw => '> # Bar'}],
+ {text => 'baz',quoter => '>',raw => '> baz'}
],
{text => '',empty => '1',quoter => '',raw => ''},
- {text => 'quux',empty => '',quoter => '',raw => 'quux'}],
+ {text => 'quux',quoter => '',raw => 'quux'}],
"Sample text is organized properly");
$b = <<EOF;
@@ -43,17 +43,17 @@ $b_dump =
[
{ text => '', empty => '1', quoter => '', raw => '' },
[
- { text => 'foo', empty => '', quoter => '>', raw => '> foo' },
+ { text => 'foo', quoter => '>', raw => '> foo' },
[
[
- { text => 'baz', empty => '', quoter => '> > >',
+ { text => 'baz', quoter => '> > >',
raw => '> > > baz' }
],
- { text => 'quux', empty => '', quoter => '> >', raw => '> > quux' }
+ { text => 'quux', quoter => '> >', raw => '> > quux' }
],
- { text => 'quuux', empty => '', quoter => '>', raw => '> quuux' }
+ { text => 'quuux', quoter => '>', raw => '> quuux' }
],
- { text => 'quuuux', empty => '', quoter => '', raw => 'quuuux' }
+ { text => 'quuuux', quoter => '', raw => 'quuuux' }
];
diff --git a/t/2.t b/t/2.t
index 5f80fab..509faf4 100644
--- a/t/2.t
+++ b/t/2.t
@@ -45,7 +45,6 @@ $expected = [
'quoter' => '>>>>>',
'text' => '"dc" == darren chamberlain writes:',
'raw' => '>>>>> "dc" == darren chamberlain writes:',
- 'empty' => ''
}
]
],
@@ -64,7 +63,6 @@ that uses Template gets executed.',
'raw' => '>> If I don\'t do "use Template;" in my startup script, each child will
>> get the pleasure of loading and compiling it all when the first script
>> that uses Template gets executed.',
- 'empty' => ''
}
],
{
@@ -80,7 +78,6 @@ that uses Template gets executed.',
happens to use Template, in which case you\'ll be OK.',
'raw' => 'dc> Unless one of the other modules that you use in your startup script
dc> happens to use Template, in which case you\'ll be OK.',
- 'empty' => ''
}
],
{
@@ -93,7 +90,6 @@ dc> happens to use Template, in which case you\'ll be OK.',
'quoter' => '',
'text' => 'Well, that\'s still "use Template;" as far as I\'m concerned.',
'raw' => 'Well, that\'s still "use Template;" as far as I\'m concerned.',
- 'empty' => ''
},
{
'quoter' => '',
@@ -109,7 +105,6 @@ template.',
'raw' => 'I was really just being pedantic... but think of a hosting situation
where the startup is pretty bare, and some Registry program uses the
template.',
- 'empty' => ''
},
{
'quoter' => '',
@@ -123,7 +118,6 @@ template.',
even if it does the right thing most of the time.',
'raw' => 'I personally don\'t think the preload should be called automagically,
even if it does the right thing most of the time.',
- 'empty' => ''
},
{
'quoter' => '',
@@ -132,10 +126,10 @@ even if it does the right thing most of the time.',
'empty' => '1'
},
{
+ 'separator' => '1',
'quoter' => '',
'text' => '_______________________________________________',
'raw' => '_______________________________________________',
- 'empty' => ''
},
{
'quoter' => '',
@@ -145,7 +139,6 @@ http://www.template-toolkit.org/mailman/listinfo/templates',
'raw' => 'templates mailing list
templates at template-toolkit.org
http://www.template-toolkit.org/mailman/listinfo/templates',
- 'empty' => ''
}
];
diff --git a/t/3.t b/t/3.t
index 0c57a5d..8b17252 100644
--- a/t/3.t
+++ b/t/3.t
@@ -36,7 +36,6 @@ $expected = [
zxc',
'raw' => 'From: "Brian Christopher Robinson" <brian.c.robinson at trw.com>
zxc',
- 'empty' => ''
},
[
[
@@ -52,7 +51,6 @@ work.',
> > faciliitated by worked very hard for a reasonably workday, then
> > leaving... thus having time to deal with personal issues when not at
> > work.',
- 'empty' => ''
}
]
],
@@ -60,21 +58,18 @@ work.',
'quoter' => '',
'text' => 'iabc',
'raw' => 'iabc',
- 'empty' => ''
},
[
{
'quoter' => '>',
'text' => 'Unfortunately, personal issues can\'t be conveniently shoved aside',
'raw' => '> Unfortunately, personal issues can\'t be conveniently shoved aside',
- 'empty' => ''
}
],
{
'quoter' => '',
'text' => 'eight',
'raw' => 'eight',
- 'empty' => ''
},
[
{
@@ -83,14 +78,12 @@ work.',
realted to picking them up and dropping them off at various times, as',
'raw' => '> hours a day. People with kids especially have to deal with issues
> realted to picking them up and dropping them off at various times, as',
- 'empty' => ''
}
],
{
'quoter' => '',
'text' => 'x',
'raw' => 'x',
- 'empty' => ''
}
];
diff --git a/t/5.t b/t/5.t
index a0fa6b2..2db0f4b 100644
--- a/t/5.t
+++ b/t/5.t
@@ -19,13 +19,12 @@ use Data::Dumper;
$empty_deeply = [
{
'text' => undef,
- 'empty' => undef,
'quoter' => undef,
'raw' => undef
}
];
-is_deeply(extract($a),$empty_deeply);
+is_deeply(extract($a),$empty_deeply) or diag Dumper(extract($a));
$b = undef;
-is_deeply(extract($b),$empty_deeply);
+is_deeply(extract($b),$empty_deeply) or diag Dumper(extract($b));
diff --git a/t/6.t b/t/6.t
index ba03250..78f1869 100644
--- a/t/6.t
+++ b/t/6.t
@@ -14,9 +14,9 @@ EOF
my $a_data =
[
[
- { 'text' => 'a', 'empty' => '', 'quoter' => '>', 'raw' => '> a' },
- [ { 'text' => 'b', 'empty' => '', 'quoter' => '>>', 'raw' => '>> b' } ],
- { 'text' => 'c', 'empty' => '', 'quoter' => '>', 'raw' => '> c' }
+ { 'text' => 'a', 'quoter' => '>', 'raw' => '> a' },
+ [ { 'text' => 'b', 'quoter' => '>>', 'raw' => '>> b' } ],
+ { 'text' => 'c', 'quoter' => '>', 'raw' => '> c' }
]
];
@@ -33,9 +33,9 @@ EOF
$a_data =
[
- [ { 'text' => 'a', 'empty' => '', 'quoter' => '>', 'raw' => '> a' } ],
- [ { 'text' => 'b', 'empty' => '', 'quoter' => '=>', 'raw' => '=> b' } ],
- [ { 'text' => 'c', 'empty' => '', 'quoter' => '>', 'raw' => '> c' } ]
+ [ { 'text' => 'a', 'quoter' => '>', 'raw' => '> a' } ],
+ [ { 'text' => 'b', 'quoter' => '=>', 'raw' => '=> b' } ],
+ [ { 'text' => 'c', 'quoter' => '>', 'raw' => '> c' } ]
];
is_deeply(extract($a),$a_data,"correctly parse => delimiter");
@@ -54,11 +54,11 @@ EOF
$a_data =
[
- [ { 'text' => 'a', 'empty' => '', 'quoter' => '>', 'raw' => '> a' } ],
+ [ { 'text' => 'a', 'quoter' => '>', 'raw' => '> a' } ],
{ 'text' => '', 'empty' => 1, 'quoter' => '', 'raw' => '' },
- [ { 'text' => 'b', 'empty' => '', 'quoter' => '=>', 'raw' => '=> b' } ],
+ [ { 'text' => 'b', 'quoter' => '=>', 'raw' => '=> b' } ],
{ 'text' => '', 'empty' => 1, 'quoter' => '', 'raw' => '' },
- [ { 'text' => 'c', 'empty' => '', 'quoter' => '>', 'raw' => '> c' } ]
+ [ { 'text' => 'c', 'quoter' => '>', 'raw' => '> c' } ]
];
is_deeply(extract($a),$a_data,"correctly parse => delimiter with blank lines");
@@ -93,9 +93,9 @@ EOF
$a_data =
[
- [ { 'text' => 'a', 'empty' => '', 'quoter' => '>', 'raw' => '> a' } ],
- { 'text' => 'cpan > b', 'empty' => '', 'quoter' => '', 'raw' => 'cpan > b' },
- [ { 'text' => 'c', 'empty' => '', 'quoter' => '>', 'raw' => '> c' } ],
+ [ { 'text' => 'a', 'quoter' => '>', 'raw' => '> a' } ],
+ { 'text' => 'cpan > b', 'quoter' => '', 'raw' => 'cpan > b' },
+ [ { 'text' => 'c', 'quoter' => '>', 'raw' => '> c' } ],
];
is_deeply(extract($a),$a_data,"correctly handles a non-delimiter");
diff --git a/t/7.t b/t/7.t
index 13cee9c..322b003 100644
--- a/t/7.t
+++ b/t/7.t
@@ -12,7 +12,6 @@ use_ok('Text::Quoted');
$a = Encode::decode_utf8("x\303\203 \tz");
is_deeply( extract($a), [ {
text => Encode::decode_utf8("x\303\203 z"),
- empty => '',
quoter => '',
raw => Encode::decode_utf8("x\303\203 z"),
} ], "No segfault");
commit 90340d6f8972dd9c46179ba969aa17bd0e7becbd
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Mar 15 19:30:46 2010 +0300
merge 6.t into 1.t
diff --git a/t/1.t b/t/1.t
index a263d73..ba03a1e 100644
--- a/t/1.t
+++ b/t/1.t
@@ -1,19 +1,12 @@
-# Before `make install' is performed this script should be runnable with
-# `make test'. After `make install' it should work as `perl 1.t'
+use strict;
+use warnings;
-#########################
-
-# change 'tests => 1' to 'tests => last_test_to_print';
-
-use Test::More tests => 3;
+use Test::More tests => 8;
BEGIN { use_ok('Text::Quoted') };
-#########################
-
-# Insert your test code below, the Test::More module is use()ed here so read
-# its man page ( perldoc Test::More ) for help writing this test script.
+use Data::Dumper;
-$a = <<EOF;
+my $a = <<EOF;
> foo
> # Bar
> baz
@@ -30,7 +23,7 @@ is_deeply(extract($a),
{text => 'quux',quoter => '',raw => 'quux'}],
"Sample text is organized properly");
-$b = <<EOF;
+$a = <<EOF;
> foo
> > > baz
@@ -39,7 +32,7 @@ $b = <<EOF;
quuuux
EOF
-$b_dump =
+my $a_dump =
[
{ text => '', empty => '1', quoter => '', raw => '' },
[
@@ -56,5 +49,102 @@ $b_dump =
{ text => 'quuuux', quoter => '', raw => 'quuuux' }
];
+is_deeply(extract($a), $a_dump, "Skipping levels works OK");
+
+#########################
+# handle nested comments with common >
+$a = <<EOF;
+> a
+>> b
+> c
+EOF
+
+$a_dump =
+ [
+ [
+ { 'text' => 'a', 'quoter' => '>', 'raw' => '> a' },
+ [ { 'text' => 'b', 'quoter' => '>>', 'raw' => '>> b' } ],
+ { 'text' => 'c', 'quoter' => '>', 'raw' => '> c' }
+ ]
+ ];
+
+is_deeply(extract($a),$a_dump,"correctly parse >> delimiter");
+
+#############
+# when the quoter changes in the middle of things, don't get confused
+
+$a = <<EOF;
+> a
+=> b
+> c
+EOF
+
+$a_dump =
+ [
+ [ { 'text' => 'a', 'quoter' => '>', 'raw' => '> a' } ],
+ [ { 'text' => 'b', 'quoter' => '=>', 'raw' => '=> b' } ],
+ [ { 'text' => 'c', 'quoter' => '>', 'raw' => '> c' } ]
+ ];
+
+is_deeply(extract($a),$a_dump,"correctly parse => delimiter");
+
+#############
+# when the quoter changes in the middle of things, don't get confused
+# blank lines shouldn't affect it
+
+$a = <<EOF;
+> a
+
+=> b
+
+> c
+EOF
+
+$a_dump =
+ [
+ [ { 'text' => 'a', 'quoter' => '>', 'raw' => '> a' } ],
+ { 'text' => '', 'empty' => 1, 'quoter' => '', 'raw' => '' },
+ [ { 'text' => 'b', 'quoter' => '=>', 'raw' => '=> b' } ],
+ { 'text' => '', 'empty' => 1, 'quoter' => '', 'raw' => '' },
+ [ { 'text' => 'c', 'quoter' => '>', 'raw' => '> c' } ]
+ ];
+
+is_deeply(extract($a),$a_dump,"correctly parse => delimiter with blank lines");
+
+#############
+# one of the real world quoter breakage examples was cpan>
+# also, no text is required for the quoter to break things
+
+$a = <<EOF;
+>
+cpan>
+>
+EOF
+
+$a_dump =
+ [
+ [ { 'text' => '', 'empty' => 1, 'quoter' => '>', 'raw' => '>' } ],
+ [ { 'text' => '', 'empty' => 1, 'quoter' => 'cpan>', 'raw' => 'cpan>' } ],
+ [ { 'text' => '', 'empty' => 1, 'quoter' => '>', 'raw' => '>' } ]
+ ];
+
+is_deeply(extract($a),$a_dump,"correctly parse cpan> delimiter with no text");
+
+############
+# just checking that when the cpan> quoter gets a space, we handle it properly
+
+$a = <<EOF;
+> a
+cpan > b
+> c
+EOF
+
+$a_dump =
+ [
+ [ { 'text' => 'a', 'quoter' => '>', 'raw' => '> a' } ],
+ { 'text' => 'cpan > b', 'quoter' => '', 'raw' => 'cpan > b' },
+ [ { 'text' => 'c', 'quoter' => '>', 'raw' => '> c' } ],
+ ];
+
+is_deeply(extract($a),$a_dump,"correctly handles a non-delimiter");
-is_deeply(extract($b), $b_dump, "Skipping levels works OK");
diff --git a/t/6.t b/t/6.t
deleted file mode 100644
index 78f1869..0000000
--- a/t/6.t
+++ /dev/null
@@ -1,101 +0,0 @@
-use strict;
-use warnings;
-use Text::Quoted;
-use Test::More tests => 5;
-
-#########################
-# handle nested comments with common >
-my $a = <<EOF;
-> a
->> b
-> c
-EOF
-
-my $a_data =
- [
- [
- { 'text' => 'a', 'quoter' => '>', 'raw' => '> a' },
- [ { 'text' => 'b', 'quoter' => '>>', 'raw' => '>> b' } ],
- { 'text' => 'c', 'quoter' => '>', 'raw' => '> c' }
- ]
- ];
-
-is_deeply(extract($a),$a_data,"correctly parse >> delimiter");
-
-#############
-# when the quoter changes in the middle of things, don't get confused
-
-$a = <<EOF;
-> a
-=> b
-> c
-EOF
-
-$a_data =
- [
- [ { 'text' => 'a', 'quoter' => '>', 'raw' => '> a' } ],
- [ { 'text' => 'b', 'quoter' => '=>', 'raw' => '=> b' } ],
- [ { 'text' => 'c', 'quoter' => '>', 'raw' => '> c' } ]
- ];
-
-is_deeply(extract($a),$a_data,"correctly parse => delimiter");
-
-#############
-# when the quoter changes in the middle of things, don't get confused
-# blank lines shouldn't affect it
-
-$a = <<EOF;
-> a
-
-=> b
-
-> c
-EOF
-
-$a_data =
- [
- [ { 'text' => 'a', 'quoter' => '>', 'raw' => '> a' } ],
- { 'text' => '', 'empty' => 1, 'quoter' => '', 'raw' => '' },
- [ { 'text' => 'b', 'quoter' => '=>', 'raw' => '=> b' } ],
- { 'text' => '', 'empty' => 1, 'quoter' => '', 'raw' => '' },
- [ { 'text' => 'c', 'quoter' => '>', 'raw' => '> c' } ]
- ];
-
-is_deeply(extract($a),$a_data,"correctly parse => delimiter with blank lines");
-
-#############
-# one of the real world quoter breakage examples was cpan>
-# also, no text is required for the quoter to break things
-
-$a = <<EOF;
->
-cpan>
->
-EOF
-
-$a_data =
- [
- [ { 'text' => '', 'empty' => 1, 'quoter' => '>', 'raw' => '>' } ],
- [ { 'text' => '', 'empty' => 1, 'quoter' => 'cpan>', 'raw' => 'cpan>' } ],
- [ { 'text' => '', 'empty' => 1, 'quoter' => '>', 'raw' => '>' } ]
- ];
-
-is_deeply(extract($a),$a_data,"correctly parse cpan> delimiter with no text");
-
-############
-# just checking that when the cpan> quoter gets a space, we handle it properly
-
-$a = <<EOF;
-> a
-cpan > b
-> c
-EOF
-
-$a_data =
- [
- [ { 'text' => 'a', 'quoter' => '>', 'raw' => '> a' } ],
- { 'text' => 'cpan > b', 'quoter' => '', 'raw' => 'cpan > b' },
- [ { 'text' => 'c', 'quoter' => '>', 'raw' => '> c' } ],
- ];
-
-is_deeply(extract($a),$a_data,"correctly handles a non-delimiter");
commit 6fe4ed1a58819aacc8c2f0d1366fae2642b7d4bc
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Mar 15 19:31:58 2010 +0300
rename tests
diff --git a/t/1.t b/t/basics.t
similarity index 100%
rename from t/1.t
rename to t/basics.t
diff --git a/t/5.t b/t/empty_text.t
similarity index 100%
rename from t/5.t
rename to t/empty_text.t
commit 8d7b32ff45d432d8fa176b5c47f0b7ff515c4c54
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Mar 15 19:33:40 2010 +0300
make test name meaningful
diff --git a/t/7.t b/t/expand_tab_segfault.t
similarity index 100%
rename from t/7.t
rename to t/expand_tab_segfault.t
commit 5d82be1240f11138f611ea6e14bf0d6887d59fe5
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Mar 15 19:35:54 2010 +0300
life_sample.* tests
diff --git a/t/2.t b/t/life_sample.1.t
similarity index 100%
rename from t/2.t
rename to t/life_sample.1.t
diff --git a/t/3.t b/t/life_sample.2.t
similarity index 100%
rename from t/3.t
rename to t/life_sample.2.t
diff --git a/t/4.t b/t/life_sample.3.t
similarity index 100%
rename from t/4.t
rename to t/life_sample.3.t
commit 050678296cdc1b8edf9b8e8022e212d789731387
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Mar 15 19:36:57 2010 +0300
manifest
diff --git a/MANIFEST b/MANIFEST
index 591031e..5b74e35 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -12,10 +12,10 @@ MANIFEST This list of files
META.yml
Quoted.pm
README
-t/1.t
-t/2.t
-t/3.t
-t/4.t
-t/5.t
-t/6.t
-t/7.t
+t/basics.t
+t/empty_text.t
+t/expand_tab_segfault.t
+t/life_sample.1.t
+t/life_sample.2.t
+t/life_sample.3.t
+t/separator.t
commit b09033ff84653aec5d60f491b14011cf6a07a21f
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Mar 15 19:42:03 2010 +0300
update changelog
diff --git a/Changes b/Changes
index a3908f3..eab7af4 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,13 @@
Revision history for Perl extension Text::Quoted.
+2.06 Mon Mar 15 2010
+ - make extracting more effective
+ - line with only '=' characters is not treated as quoter
+ anymore, but separator
+ - mark separating lines with "separator => 1" hash entry
+ - don't return "empty => ''" hash key
+ - update tests
+
2.05 Wed Jan 24 2008
- fix tests failure under perl 5.6.x,
thanks to David Cantrell for cpan testing it
commit 9cc59a1a40c6bc8e19f8125c1d6e011ae47e15c6
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Mar 15 19:43:30 2010 +0300
update .gitignore
diff --git a/.gitignore b/.gitignore
index 508fefb..c9502c6 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,4 +1,5 @@
Makefile
+Makefile.old
pm_to_blib
blib/
MANIFEST.old
commit ef021d3827a2d7c57370555aa925640f7449dc74
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Mar 15 19:44:55 2010 +0300
update M::I
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index 89a8653..60583cc 100644
--- a/inc/Module/Install.pm
+++ b/inc/Module/Install.pm
@@ -17,20 +17,31 @@ package Module::Install;
# 3. The ./inc/ version of Module::Install loads
# }
-use 5.004;
+use 5.005;
use strict 'vars';
-use vars qw{$VERSION};
+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 = '0.68';
+ # 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 = '0.94';
+
+ # Storage for the pseudo-singleton
+ $MAIN = undef;
+
+ *inc::Module::Install::VERSION = *VERSION;
+ @inc::Module::Install::ISA = __PACKAGE__;
+
}
+
+
+
+
# 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.
@@ -38,27 +49,40 @@ BEGIN {
# 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";
+unless ( $INC{$file} ) { die <<"END_DIE" }
+
Please invoke ${\__PACKAGE__} with:
- use inc::${\__PACKAGE__};
+ use inc::${\__PACKAGE__};
not:
- use ${\__PACKAGE__};
+ use ${\__PACKAGE__};
END_DIE
-}
+
+
+
+
# 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 and (stat($0))[9] > time ) {
- die << "END_DIE";
-Your installer $0 has a modification time in the future.
+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.
@@ -67,113 +91,153 @@ 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));
+
+
+
+
+
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
-*inc::Module::Install::VERSION = *VERSION;
- at inc::Module::Install::ISA = __PACKAGE__;
-
sub autoload {
- my $self = shift;
- my $who = $self->_caller;
- my $cwd = Cwd::cwd();
- my $sym = "${who}::AUTOLOAD";
- $sym->{$cwd} = sub {
- my $pwd = Cwd::cwd();
- if ( my $code = $sym->{$pwd} ) {
- # delegate back to parent dirs
- goto &$code unless $cwd eq $pwd;
- }
- $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
- unshift @_, ($self, $1);
- goto &{$self->can('call')} unless uc($1) eq $1;
- };
+ my $self = shift;
+ my $who = $self->_caller;
+ my $cwd = Cwd::cwd();
+ my $sym = "${who}::AUTOLOAD";
+ $sym->{$cwd} = sub {
+ my $pwd = Cwd::cwd();
+ if ( my $code = $sym->{$pwd} ) {
+ # Delegate back to parent dirs
+ goto &$code unless $cwd eq $pwd;
+ }
+ $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
+ 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 import {
- my $class = shift;
- my $self = $class->new(@_);
- my $who = $self->_caller;
-
- unless ( -f $self->{file} ) {
- 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"};
- }
-
- *{"${who}::AUTOLOAD"} = $self->autoload;
- $self->preload;
-
- # Unregister loader and worker packages so subdirs can use them again
- delete $INC{"$self->{file}"};
- delete $INC{"$self->{path}.pm"};
+ my $class = shift;
+ my $self = $class->new(@_);
+ my $who = $self->_caller;
+
+ unless ( -f $self->{file} ) {
+ 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"};
+ }
+
+ *{"${who}::AUTOLOAD"} = $self->autoload;
+ $self->preload;
+
+ # Unregister loader and worker packages so subdirs can use them again
+ delete $INC{"$self->{file}"};
+ delete $INC{"$self->{path}.pm"};
+
+ # Save to the singleton
+ $MAIN = $self;
+
+ return 1;
}
sub preload {
- my ($self) = @_;
-
- unless ( $self->{extensions} ) {
- $self->load_extensions(
- "$self->{prefix}/$self->{path}", $self
- );
- }
-
- my @exts = @{$self->{extensions}};
- unless ( @exts ) {
- my $admin = $self->{admin};
- @exts = $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 ) {
- *{"${who}::$name"} = sub {
- ${"${who}::AUTOLOAD"} = "${who}::$name";
- goto &{"${who}::AUTOLOAD"};
- };
- }
+ 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 ) {
+ *{"${who}::$name"} = sub {
+ ${"${who}::AUTOLOAD"} = "${who}::$name";
+ goto &{"${who}::AUTOLOAD"};
+ };
+ }
}
sub new {
- my ($class, %args) = @_;
-
- # ignore the prefix on extension modules built from top level.
- my $base_path = Cwd::abs_path($FindBin::Bin);
- unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
- delete $args{prefix};
- }
-
- return $args{_self} if $args{_self};
-
- $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";
-
- bless( \%args, $class );
+ my ($class, %args) = @_;
+
+ # ignore the prefix on extension modules built from top level.
+ my $base_path = Cwd::abs_path($FindBin::Bin);
+ unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
+ delete $args{prefix};
+ }
+
+ return $args{_self} if $args{_self};
+
+ $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 {
@@ -184,98 +248,198 @@ sub call {
}
sub load {
- my ($self, $method) = @_;
+ my ($self, $method) = @_;
- $self->load_extensions(
- "$self->{prefix}/$self->{path}", $self
- ) unless $self->{extensions};
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ ) unless $self->{extensions};
- foreach my $obj (@{$self->{extensions}}) {
- return $obj if $obj->can($method);
- }
+ foreach my $obj (@{$self->{extensions}}) {
+ return $obj if $obj->can($method);
+ }
- my $admin = $self->{admin} or die <<"END_DIE";
+ 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;
+ my $obj = $admin->load($method, 1);
+ push @{$self->{extensions}}, $obj;
- $obj;
+ $obj;
}
sub load_extensions {
- my ($self, $path, $top) = @_;
-
- unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
- unshift @INC, $self->{prefix};
- }
-
- foreach my $rv ( $self->find_extensions($path) ) {
- my ($file, $pkg) = @{$rv};
- next if $self->{pathnames}{$pkg};
-
- local $@;
- my $new = eval { require $file; $pkg->can('new') };
- unless ( $new ) {
- warn $@ if $@;
- next;
- }
- $self->{pathnames}{$pkg} = delete $INC{$file};
- push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
- }
-
- $self->{extensions} ||= [];
+ my ($self, $path, $top) = @_;
+
+ unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
+ unshift @INC, $self->{prefix};
+ }
+
+ foreach my $rv ( $self->find_extensions($path) ) {
+ my ($file, $pkg) = @{$rv};
+ next if $self->{pathnames}{$pkg};
+
+ local $@;
+ my $new = eval { require $file; $pkg->can('new') };
+ unless ( $new ) {
+ warn $@ if $@;
+ next;
+ }
+ $self->{pathnames}{$pkg} = delete $INC{$file};
+ push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
+ }
+
+ $self->{extensions} ||= [];
}
sub find_extensions {
- my ($self, $path) = @_;
-
- my @found;
- File::Find::find( 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) ) {
- open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
- my $in_pod = 0;
- while ( <PKGFILE> ) {
- $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;
- }
- }
- close PKGFILE;
- }
-
- push @found, [ $file, $pkg ];
- }, $path ) if -d $path;
-
- @found;
+ my ($self, $path) = @_;
+
+ my @found;
+ File::Find::find( 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($subpath . '.pm');
+ my $in_pod = 0;
+ foreach ( split //, $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;
+ my $depth = 0;
+ my $call = caller($depth);
+ while ( $call eq __PACKAGE__ ) {
+ $depth++;
+ $call = caller($depth);
+ }
+ return $call;
+}
+
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
+sub _read {
+ local *FH;
+ open( FH, '<', $_[0] ) or die "open($_[0]): $!";
+ my $string = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $string;
+}
+END_NEW
+sub _read {
+ local *FH;
+ open( FH, "< $_[0]" ) or die "open($_[0]): $!";
+ my $string = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $string;
+}
+END_OLD
+
+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;
+}
+
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
+sub _write {
+ local *FH;
+ open( FH, '>', $_[0] ) or die "open($_[0]): $!";
+ foreach ( 1 .. $#_ ) {
+ print FH $_[$_] or die "print($_[0]): $!";
+ }
+ close FH or die "close($_[0]): $!";
+}
+END_NEW
+sub _write {
+ local *FH;
+ open( FH, "> $_[0]" ) or die "open($_[0]): $!";
+ foreach ( 1 .. $#_ ) {
+ print FH $_[$_] or die "print($_[0]): $!";
+ }
+ close FH or die "close($_[0]): $!";
+}
+END_OLD
+
+# _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($_[0]) <=> _version($_[1]);
+}
+
+# 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 - 2010 Adam Kennedy.
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index 49dfde6..a76a7a6 100644
--- a/inc/Module/Install/Base.pm
+++ b/inc/Module/Install/Base.pm
@@ -1,7 +1,11 @@
#line 1
package Module::Install::Base;
-$VERSION = '0.68';
+use strict 'vars';
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '0.94';
+}
# Suspend handler for "redefined" warnings
BEGIN {
@@ -9,52 +13,56 @@ BEGIN {
$SIG{__WARN__} = sub { $w };
}
-### This is the ONLY module that shouldn't have strict on
-# use strict;
-
-#line 41
+#line 42
sub new {
- my ($class, %args) = @_;
-
- foreach my $method ( qw(call load) ) {
- *{"$class\::$method"} = sub {
- shift()->_top->$method(@_);
- } unless defined &{"$class\::$method"};
- }
-
- bless( \%args, $class );
+ 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 {
- my $self = shift;
- local $@;
- my $autoload = eval { $self->_top->autoload } or return;
- goto &$autoload;
+ local $@;
+ my $func = eval { shift->_top->autoload } or return;
+ goto &$func;
}
-#line 76
+#line 75
-sub _top { $_[0]->{_top} }
+sub _top {
+ $_[0]->{_top};
+}
-#line 89
+#line 90
sub admin {
- $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
+ $_[0]->_top->{admin}
+ or
+ Module::Install::Base::FakeAdmin->new;
}
+#line 106
+
sub is_admin {
- $_[0]->admin->VERSION;
+ $_[0]->admin->VERSION;
}
sub DESTROY {}
package Module::Install::Base::FakeAdmin;
-my $Fake;
-sub new { $Fake ||= bless(\@_, $_[0]) }
+my $fake;
+
+sub new {
+ $fake ||= bless(\@_, $_[0]);
+}
sub AUTOLOAD {}
@@ -67,4 +75,4 @@ BEGIN {
1;
-#line 138
+#line 154
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
index ec66fdb..1da28d4 100644
--- a/inc/Module/Install/Can.pm
+++ b/inc/Module/Install/Can.pm
@@ -2,18 +2,16 @@
package Module::Install::Can;
use strict;
-use Module::Install::Base;
-use Config ();
-### This adds a 5.005 Perl version dependency.
-### This is a bug and will be fixed.
-use File::Spec ();
-use ExtUtils::MakeMaker ();
-
-use vars qw{$VERSION $ISCORE @ISA};
+use Config ();
+use File::Spec ();
+use ExtUtils::MakeMaker ();
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.94';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
# check if we can load some module
@@ -39,6 +37,7 @@ sub can_run {
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 '';
my $abs = File::Spec->catfile($dir, $_[1]);
return $abs if (-x $abs or $abs = MM->maybe_command($abs));
}
@@ -79,4 +78,4 @@ if ( $^O eq 'cygwin' ) {
__END__
-#line 157
+#line 156
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
index e0dd6db..b5375a4 100644
--- a/inc/Module/Install/Fetch.pm
+++ b/inc/Module/Install/Fetch.pm
@@ -2,24 +2,24 @@
package Module::Install::Fetch;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.94';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
sub get_file {
my ($self, %args) = @_;
- my ($scheme, $host, $path, $file) =
+ 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) =
+ ($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
}
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
index 17bd8a7..1dacaf2 100644
--- a/inc/Module/Install/Makefile.pm
+++ b/inc/Module/Install/Makefile.pm
@@ -2,14 +2,14 @@
package Module::Install::Makefile;
use strict 'vars';
-use Module::Install::Base;
-use ExtUtils::MakeMaker ();
+use ExtUtils::MakeMaker ();
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.94';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
sub Makefile { $_[0] }
@@ -34,17 +34,28 @@ sub 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
+}
+
sub makemaker_args {
my $self = shift;
- my $args = ($self->{makemaker_args} ||= {});
- %$args = ( %$args, @_ ) if @_;
- $args;
+ my $args = ( $self->{makemaker_args} ||= {} );
+ %$args = ( %$args, @_ );
+ return $args;
}
# For mm args that take multiple space-seperated args,
# append an argument to the current list.
sub makemaker_append {
- my $self = sShift;
+ my $self = shift;
my $name = shift;
my $args = $self->makemaker_args;
$args->{name} = defined $args->{$name}
@@ -63,18 +74,18 @@ sub build_subdirs {
sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
- %$clean = (
- %$clean,
- FILES => join(' ', grep length, $clean->{FILES}, @_),
+ %$clean = (
+ %$clean,
+ FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
);
}
sub realclean_files {
- my $self = shift;
+ my $self = shift;
my $realclean = $self->makemaker_args->{realclean} ||= {};
- %$realclean = (
- %$realclean,
- FILES => join(' ', grep length, $realclean->{FILES}, @_),
+ %$realclean = (
+ %$realclean,
+ FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
);
}
@@ -104,9 +115,12 @@ sub tests_recursive {
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
- require File::Find;
%test_dir = ();
+ require File::Find;
File::Find::find( \&_wanted_t, $dir );
+ if ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
+ File::Find::find( \&_wanted_t, 'xt' );
+ }
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
@@ -114,60 +128,122 @@ 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 ) {
+ # MakeMaker can complain about module versions that include
+ # an underscore, even though its own version may contain one!
+ # Hence the funny regexp to get rid of it. See RT #35800
+ # for details.
+ my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
+ $self->build_requires( 'ExtUtils::MakeMaker' => $v );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => $v );
+ } 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.42 );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
+ }
+
+ # Generate the MakeMaker params
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
- $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
- $args->{VERSION} = $self->version || $self->determine_VERSION($args);
+ $args->{NAME} = $self->module_name || $self->name;
+ $args->{VERSION} = $self->version;
$args->{NAME} =~ s/-/::/g;
+ $DB::single = 1;
if ( $self->tests ) {
- $args->{test} = { TESTS => $self->tests };
+ $args->{test} = {
+ TESTS => $self->tests,
+ };
+ } 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) {
+ if ( $] >= 5.005 ) {
$args->{ABSTRACT} = $self->abstract;
$args->{AUTHOR} = $self->author;
}
- if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
- $args->{NO_META} = 1;
+ if ( $self->makemaker(6.10) ) {
+ $args->{NO_META} = 1;
+ #$args->{NO_MYMETA} = 1;
}
- if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
+ if ( $self->makemaker(6.17) and $self->sign ) {
$args->{SIGN} = 1;
}
unless ( $self->is_admin ) {
delete $args->{SIGN};
}
- # merge both kinds of requires into prereq_pm
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->build_requires, $self->requires)
+ ($self->configure_requires, $self->build_requires)
);
- # merge both kinds of requires into prereq_pm
+ # Remove any reference to perl, BUILD_REQUIRES doesn't support it
+ delete $args->{BUILD_REQUIRES}->{perl};
+
+ # Delete bundled dists from prereq_pm
my $subdirs = ($args->{DIR} ||= []);
if ($self->bundles) {
foreach my $bundle (@{ $self->bundles }) {
my ($file, $dir) = @$bundle;
push @$subdirs, $dir if -d $dir;
- delete $prereq->{$file};
+ delete $build_prereq->{$file}; #Delete from build prereqs only
}
}
+ 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;
+ }
}
$args->{INSTALLDIRS} = $self->installdirs;
- my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
+ my %args = map {
+ ( $_ => $args->{$_} ) } grep {defined($args->{$_} )
+ } keys %$args;
my $user_preop = delete $args{dist}->{PREOP};
- if (my $preop = $self->admin->preop($user_preop)) {
- $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);
@@ -180,7 +256,7 @@ sub fix_up_makefile {
my $top_class = ref($self->_top) || '';
my $top_version = $self->_top->VERSION || '';
- my $preamble = $self->preamble
+ my $preamble = $self->preamble
? "# Preamble by $top_class $top_version\n"
. $self->preamble
: '';
@@ -205,7 +281,7 @@ sub fix_up_makefile {
#$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;
+ $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;
@@ -234,4 +310,4 @@ sub postamble {
__END__
-#line 363
+#line 439
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index f77d68a..0710b3c 100644
--- a/inc/Module/Install/Metadata.pm
+++ b/inc/Module/Install/Metadata.pm
@@ -2,335 +2,647 @@
package Module::Install::Metadata;
use strict 'vars';
-use Module::Install::Base;
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.94';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
+my @boolean_keys = qw{
+ sign
+};
+
my @scalar_keys = qw{
- name module_name abstract author version license
- distribution_type perl_version tests installdirs
+ name
+ module_name
+ abstract
+ author
+ version
+ distribution_type
+ tests
+ installdirs
};
my @tuple_keys = qw{
- build_requires requires recommends bundles
+ configure_requires
+ build_requires
+ requires
+ recommends
+ bundles
+ resources
};
-sub Meta { shift }
-sub Meta_ScalarKeys { @scalar_keys }
-sub Meta_TupleKeys { @tuple_keys }
-
-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 (@tuple_keys) {
- *$key = sub {
- my $self = shift;
- return $self->{values}{$key} unless @_;
-
- my @rv;
- while (@_) {
- my $module = shift or last;
- my $version = shift || 0;
- if ( $module eq 'perl' ) {
- $version =~ s{^(\d+)\.(\d+)\.(\d+)}
- {$1 + $2/1_000 + $3/1_000_000}e;
- $self->perl_version($version);
- next;
- }
- my $rv = [ $module, $version ];
- push @rv, $rv;
- }
- push @{ $self->{values}{$key} }, @rv;
- @rv;
- };
-}
-
-# configure_requires is currently a null-op
-sub configure_requires { 1 }
+my @resource_keys = qw{
+ homepage
+ bugtracker
+ repository
+};
+
+my @array_keys = qw{
+ keywords
+};
+
+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(@_) }
+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 sign {
- my $self = shift;
- return $self->{'values'}{'sign'} if defined wantarray and ! @_;
- $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
- return $self;
-}
+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;
unless ( @_ ) {
- warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
+ warn "You MUST provide an explicit true/false value to dynamic_config\n";
return $self;
}
- $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
- return $self;
+ $self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
+ return 1;
}
-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;
- die "all_from: cannot find $file from $name" unless -e $file;
- }
+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()"
+ );
- $self->version_from($file) unless $self->version;
- $self->perl_version_from($file) unless $self->perl_version;
+ # Normalize the version
+ $version = $self->_perl_version($version);
- # The remaining probes read from POD sections; if the file
- # has an accompanying .pod, use that instead
- my $pod = $file;
- if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
- $file = $pod;
- }
+ # We don't support the reall old versions
+ unless ( $version >= 5.005 ) {
+ die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
+ }
- $self->author_from($file) unless $self->author;
- $self->license_from($file) unless $self->license;
- $self->abstract_from($file) unless $self->abstract;
+ $self->{values}->{perl_version} = $version;
}
-sub provides {
- my $self = shift;
- my $provides = ( $self->{values}{provides} ||= {} );
- %$provides = (%$provides, @_) if @_;
- return $provides;
+#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',
+ artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
+ lgpl => 'http://opensource.org/licenses/lgpl-license.php',
+ lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
+ lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
+ 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,
+);
+
+sub license {
+ my $self = shift;
+ return $self->{values}->{license} unless @_;
+ my $license = shift or die(
+ 'Did not provide a value to license()'
+ );
+ $self->{values}->{license} = $license;
+
+ # Automatically fill in license URLs
+ if ( $license_urls{$license} ) {
+ $self->resources( license => $license_urls{$license} );
+ }
+
+ return 1;
}
-sub auto_provides {
- my $self = shift;
- return $self unless $self->is_admin;
+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;
- unless (-e 'MANIFEST') {
- warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
- return $self;
- }
+ # 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;
- # Avoid spurious warnings as we are not checking manifest here.
+ # 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;
- local $SIG{__WARN__} = sub {1};
- require ExtUtils::Manifest;
- local *ExtUtils::Manifest::manicheck = sub { return };
+ return 1;
+}
+
+sub provides {
+ my $self = shift;
+ my $provides = ( $self->{values}->{provides} ||= {} );
+ %$provides = (%$provides, @_) if @_;
+ return $provides;
+}
- 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 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;
+ 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} }
- : ();
+ 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};
+ 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', 0 );
-
- require YAML;
- my $data = YAML::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;
+ 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;
+ my $self = shift;
+ return $self unless $self->is_admin;
+ $self->admin->write_meta;
+ return $self;
}
sub version_from {
- my ( $self, $file ) = @_;
- require ExtUtils::MM_Unix;
- $self->version( ExtUtils::MM_Unix->parse_version($file) );
+ require ExtUtils::MM_Unix;
+ my ( $self, $file ) = @_;
+ $self->version( ExtUtils::MM_Unix->parse_version($file) );
}
sub abstract_from {
- my ( $self, $file ) = @_;
- require ExtUtils::MM_Unix;
- $self->abstract(
- bless(
- { DISTNAME => $self->name },
- 'ExtUtils::MM_Unix'
- )->parse_abstract($file)
- );
+ require ExtUtils::MM_Unix;
+ my ( $self, $file ) = @_;
+ $self->abstract(
+ bless(
+ { DISTNAME => $self->name },
+ 'ExtUtils::MM_Unix'
+ )->parse_abstract($file)
+ );
}
-sub _slurp {
- my ( $self, $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");
+ }
+}
- local *FH;
- open FH, "< $file" or die "Cannot open $file.pod: $!";
- do { local $/; <FH> };
+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, $file ) = @_;
-
- if (
- $self->_slurp($file) =~ m/
- ^
- use \s*
- v?
- ([\d_\.]+)
- \s* ;
- /ixms
- )
- {
- my $v = $1;
- $v =~ s{_}{}g;
- $self->perl_version($1);
- }
- else {
- warn "Cannot determine perl version info from $file\n";
- return;
- }
+ 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, $file ) = @_;
- my $content = $self->_slurp($file);
- 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;
- $author =~ s{E<lt>}{<}g;
- $author =~ s{E<gt>}{>}g;
- $self->author($author);
- }
- else {
- warn "Cannot determine author info from $file\n";
- }
+ 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;
+ $author =~ s{E<lt>}{<}g;
+ $author =~ s{E<gt>}{>}g;
+ $self->author($author);
+ } else {
+ warn "Cannot determine author info from $_[0]\n";
+ }
+}
+
+sub _extract_license {
+ if (
+ $_[0] =~ m/
+ (
+ =head \d \s+
+ (?:licen[cs]e|licensing|copyrights?|legal)\b
+ .*?
+ )
+ (=head\\d.*|=cut.*|)
+ \z
+ /ixms ) {
+ my $license_text = $1;
+ my @phrases = (
+ 'under the same (?:terms|license) as (?:perl|the perl 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,
+ 'BSD license' => 'bsd', 1,
+ 'Artistic license' => 'artistic', 1,
+ 'GPL' => 'gpl', 1,
+ 'LGPL' => 'lgpl', 1,
+ 'BSD' => 'bsd', 1,
+ 'Artistic' => 'artistic', 1,
+ 'MIT' => 'mit', 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;
+ }
+ }
+ } else {
+ return;
+ }
}
sub license_from {
- my ( $self, $file ) = @_;
-
- if (
- $self->_slurp($file) =~ m/
- (
- =head \d \s+
- (?:licen[cs]e|licensing|copyright|legal)\b
- .*?
- )
- (=head\\d.*|=cut.*|)
- \z
- /ixms
- )
- {
- my $license_text = $1;
- my @phrases = (
- 'under the same (?:terms|license) as perl itself' => 'perl', 1,
- 'GNU public license' => 'gpl', 1,
- 'GNU lesser public license' => 'gpl', 1,
- 'BSD license' => 'bsd', 1,
- 'Artistic license' => 'artistic', 1,
- 'GPL' => 'gpl', 1,
- 'LGPL' => 'lgpl', 1,
- 'BSD' => 'bsd', 1,
- 'Artistic' => 'artistic', 1,
- 'MIT' => 'mit', 1,
- 'proprietary' => 'proprietary', 0,
- );
- while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
- $pattern =~ s{\s+}{\\s+}g;
- if ( $license_text =~ /\b$pattern\b/i ) {
- if ( $osi and $license_text =~ /All rights reserved/i ) {
- warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
+ 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<(
+ \Qhttp://rt.cpan.org/\E[^>]+|
+ \Qhttp://github.com/\E[\w_]+/[\w_]+/issues|
+ \Qhttp://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+([\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;
+}
+
+
+
+
+
+######################################################################
+# 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
}
- $self->license($license);
- return 1;
- }
- }
- }
-
- warn "Cannot determine license info from $file\n";
- return 'unknown';
+ 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 hashs
+ 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;
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
index 4f808c7..1ad2f8f 100644
--- a/inc/Module/Install/Win32.pm
+++ b/inc/Module/Install/Win32.pm
@@ -2,13 +2,13 @@
package Module::Install::Win32;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.94';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
# determine if the user needs nmake, and download it if needed
@@ -16,7 +16,7 @@ sub check_nmake {
my $self = shift;
$self->load('can_run');
$self->load('get_file');
-
+
require Config;
return unless (
$^O eq 'MSWin32' and
@@ -38,8 +38,7 @@ sub check_nmake {
remove => 1,
);
- if (!$rv) {
- die <<'END_MESSAGE';
+ die <<'END_MESSAGE' unless $rv;
-------------------------------------------------------------------------------
@@ -59,7 +58,7 @@ You may then resume the installation process described in README.
-------------------------------------------------------------------------------
END_MESSAGE
- }
+
}
1;
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
index 078797c..5db82af 100644
--- a/inc/Module/Install/WriteAll.pm
+++ b/inc/Module/Install/WriteAll.pm
@@ -2,42 +2,59 @@
package Module::Install::WriteAll;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.68';
- $ISCORE = 1;
+ $VERSION = '0.94';;
@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->Meta->write if $args{meta};
- $self->admin->WriteAll(%args) if $self->is_admin;
-
- if ( $0 =~ /Build.PL$/i ) {
- $self->Build->write;
- } else {
- $self->check_nmake if $args{check_nmake};
- unless ( $self->makemaker_args->{'PL_FILES'} ) {
- $self->makemaker_args( PL_FILES => {} );
- }
- if ($args{inline}) {
- $self->Inline->write;
- } else {
- $self->Makefile->write;
- }
- }
+ 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} ) {
+ $self->makemaker_args( PL_FILES => {} );
+ }
+
+ # 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;
commit 391817889e0b8e10237aa0371a3b19f379169cde
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Mar 15 19:45:03 2010 +0300
bump version, 2.06
diff --git a/META.yml b/META.yml
index e7ce278..c8c2082 100644
--- a/META.yml
+++ b/META.yml
@@ -1,19 +1,25 @@
----
-abstract: Extract the structure of a quoted mail message
-author:
- - Jesse Vincent <jesse at bestpractical.com>
+---
+abstract: 'Extract the structure of a quoted mail message'
+author:
+ - 'Jesse Vincent <jesse at bestpractical.com>'
+build_requires:
+ ExtUtils::MakeMaker: 6.42
+configure_requires:
+ ExtUtils::MakeMaker: 6.42
distribution_type: module
-generated_by: Module::Install version 0.68
+generated_by: 'Module::Install version 0.94'
license: perl
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.3.html
- version: 1.3
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
name: Text-Quoted
-no_index:
- directory:
+no_index:
+ directory:
- inc
- t
-requires:
+requires:
Text::Autoformat: 0
perl: 5.6.0
-version: 2.05
+resources:
+ license: http://dev.perl.org/licenses/
+version: 2.06
diff --git a/Quoted.pm b/Quoted.pm
index 0ab4fc3..a0fb459 100644
--- a/Quoted.pm
+++ b/Quoted.pm
@@ -1,5 +1,5 @@
package Text::Quoted;
-our $VERSION = "2.05";
+our $VERSION = "2.06";
use 5.006;
use strict;
use warnings;
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list