@@ -1,5 +1,10 @@
Revision history for Perl extension DBIx-Class-Schema-PopulateMore.
+0.18 Wednesday, June 4, 2014
+ - Port to Moo
+ - documentation typo fixes
+ - fixed a bug ...::Command where some code was not immutable
+
0.17 Monday, May 9, 2011
- Changed column definition from integer to varchar since that column takes
characters as well as numbers and the newest DBIC enforces this.
@@ -1,4 +1,4 @@
-This software is copyright (c) 2011 by John Napiorkowski, C<< <jjnapiork@cpan.org> >>.
+This software is copyright (c) 2014 by John Napiorkowski, C<< <jjnapiork@cpan.org> >>.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
@@ -12,7 +12,7 @@ b) the "Artistic License"
--- The GNU General Public License, Version 1, February 1989 ---
-This software is Copyright (c) 2011 by John Napiorkowski, C<< <jjnapiork@cpan.org> >>.
+This software is Copyright (c) 2014 by John Napiorkowski, C<< <jjnapiork@cpan.org> >>.
This is free software, licensed under:
@@ -22,7 +22,7 @@ This is free software, licensed under:
Version 1, February 1989
Copyright (C) 1989 Free Software Foundation, Inc.
- 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+ 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
@@ -272,7 +272,7 @@ That's all there is to it!
--- The Artistic License 1.0 ---
-This software is Copyright (c) 2011 by John Napiorkowski, C<< <jjnapiork@cpan.org> >>.
+This software is Copyright (c) 2014 by John Napiorkowski, C<< <jjnapiork@cpan.org> >>.
This is free software, licensed under:
@@ -3,18 +3,19 @@ abstract: 'An enhanced populate method'
author:
- 'John Napiorkowski, C<< <jjnapiork@cpan.org> >>'
build_requires:
- DBIx::Class: 0.08127
- DateTime::Format::SQLite: 0.11
- ExtUtils::MakeMaker: 6.42
+ DBIx::Class: '0.08127'
+ DateTime::Format::SQLite: '0.11'
+ ExtUtils::MakeMaker: 6.59
File::Find: 0
- Path::Class: 0.23
- SQL::Translator: 0.11007
- Test::More: 0.98
- YAML::Tiny: 1.48
+ Path::Class: '0.23'
+ SQL::Translator: '0.11007'
+ Test::More: '0.98'
+ YAML::Tiny: '1.48'
configure_requires:
- ExtUtils::MakeMaker: 6.42
+ ExtUtils::MakeMaker: 6.59
distribution_type: module
-generated_by: 'Module::Install version 1.01'
+dynamic_config: 1
+generated_by: 'Module::Install version 1.08'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -26,15 +27,17 @@ no_index:
- inc
- t
requires:
- Data::Visitor: 0.27
- DateTimeX::Easy: 0.089
- List::MoreUtils: 0.30
- Module::Pluggable: 3.9
- Moose: 1.24
- parent: 0.224
+ DateTimeX::Easy: '0.089'
+ List::MoreUtils: '0.30'
+ Module::Pluggable: '3.9'
+ Moo: '1.004006'
+ MooX::HandlesVia: '0.001005'
+ Scalar::Util: '1.35'
+ Type::Tiny: '0.042'
+ parent: '0.224'
perl: 5.8.5
resources:
homepage: http://search.cpan.org/dist/DBIx-Class-Schema-PopulateMore/
license: http://dev.perl.org/licenses/
repository: git://github.com/jjn1056/DBIx-Class-Schema-PopulateMore.git
-version: 0.17
+version: '0.18'
@@ -5,11 +5,13 @@ use warnings FATAL => 'all';
use inc::Module::Install;
requires 'parent' => '0.224';
-requires 'Moose' => '1.24';
+requires 'Moo' => '1.004006';
+requires 'MooX::HandlesVia' => '0.001005';
+requires 'Scalar::Util' => '1.35';
+requires 'Type::Tiny' => '0.042';
requires 'DateTimeX::Easy' => '0.089';
requires 'List::MoreUtils' => '0.30';
requires 'Module::Pluggable' => '3.9';
-requires 'Data::Visitor' => '0.27';
test_requires 'DBIx::Class' => '0.08127';
test_requires 'DateTime::Format::SQLite' => '0.11'; ## needed by DBIC for datetime in/deflators
@@ -10,67 +10,61 @@ Version 0.17
The following is example usage for this component.
- package Myapp::Schema;
- use base qw/DBIx::Class::Schema/;
-
-
- __PACKAGE__->load_components(qw/Schema::PopulateMore/);
- __PACKAGE__->load_namespaces();
-
-
- ## All the rest of your setup
+ package Myapp::Schema;
+ use base qw/DBIx::Class::Schema/;
+
+ __PACKAGE__->load_components(qw/Schema::PopulateMore/);
+ __PACKAGE__->load_namespaces();
+
+ ## All the rest of your setup
Then assuming you have ResultSources of Gender, Person and FriendList:
- my $setup_rows = [
-
-
- {Gender => {
- fields => 'label',
- data => {
- male => 'male',
- female => 'female',
- }}},
-
-
- {Person => {
- fields => ['name', 'age', 'gender'],
- data => {
- john => ['john', 38, "!Index:Gender.male"],
- jane => ['jane', 40, '!Index:Gender.female'],
- }}},
-
-
- {FriendList => {
- fields => ['person', 'friend', 'created_date'],
- data => {
- john_jane => [
- '!Index:Person.john',
- '!Index:Person.jane'
- '!Date: March 30, 1996',
- ],
- }}},
- ];
-
-
- $schema->populate_more($setup_rows);
+ my $setup_rows = [
+
+ {Gender => {
+ fields => 'label',
+ data => {
+ male => 'male',
+ female => 'female',
+ }}},
+
+ {Person => {
+ fields => ['name', 'age', 'gender'],
+ data => {
+ john => ['john', 38, "!Index:Gender.male"],
+ jane => ['jane', 40, '!Index:Gender.female'],
+ }}},
+
+ {FriendList => {
+ fields => ['person', 'friend', 'created_date'],
+ data => {
+ john_jane => [
+ '!Index:Person.john',
+ '!Index:Person.jane'
+ '!Date: March 30, 1996',
+ ],
+ }}},
+ ];
+
+ $schema->populate_more($setup_rows);
Please see the test cases for more detailed examples.
# DESCRIPTION
-This is a [DBIx::Class::Schema](http://search.cpan.org/perldoc?DBIx::Class::Schema) component that provides an enhanced version
-of the builtin method L<DBIx::Class::Schema/populate>. What it does is make it
+This is a [DBIx::Class::Schema](https://metacpan.org/pod/DBIx::Class::Schema) component that provides an enhanced version
+of the builtin method ["populate" in DBIx::Class::Schema](https://metacpan.org/pod/DBIx::Class::Schema#populate). What it does is make it
easier when you are doing a first time setup and need to insert a bunch of
rows, like the first time you deploy a new database, or after you update it.
-It's not as full featured as [DBIx::Class::Fixtures](http://search.cpan.org/perldoc?DBIx::Class::Fixtures) but is targeted more
+It's not as full featured as [DBIx::Class::Fixtures](https://metacpan.org/pod/DBIx::Class::Fixtures) but is targeted more
directly at making it easier to just take a prewritten perl structure --or one
loaded from a configuration file-- and setup your database.
-Most of us using [DBIx::CLass](http://search.cpan.org/perldoc?DBIx::CLass) have written a version of this at one time or
+Most of us using [DBIx::CLass](https://metacpan.org/pod/DBIx::CLass) have written a version of this at one time or
another. What is special to this component is the fact that unlike the normal
-populate method you can insert to multiple result_sources in one go. While
+populate method you can insert to multiple result\_sources in one go. While
doing this, we index the created rows so as to make it easy to reference them
in relationships. I did this because I think it's very ugly to have to type in
all the primary keys by hand, particularly if your PK is multi column, or is
@@ -83,48 +77,46 @@ This distribution supplies three expansion commands:
- Index
-Use for creating relationships. This is a string in the form of "Source.Label"
-where the Source is the name of the result source that you are creating rows in
-and Label is a key name from from key part of the data hash.
+ Use for creating relationships. This is a string in the form of "Source.Label"
+ where the Source is the name of the result source that you are creating rows in
+ and Label is a key name from the key part of the data hash.
- Env
-Get's it's value from %ENV. Typically this will be setup in your shell or at
-application runtime. This is a string in the form of "!Env:MY_ENV_VAR"
+ Get's it's value from %ENV. Typically this will be setup in your shell or at
+ application runtime. This is a string in the form of "!Env:MY\_ENV\_VAR"
- Date
-converts it's value to a [DateTime](http://search.cpan.org/perldoc?DateTime) object. Will use a various methods to try
-and coerce a string, like "today", or "January 6, 1974". Makes it easier to
-insert dates into your database without knowing or caring about the expected
-format. For this to work correctly, you need to use the class component
-[DBIx::Class::InflateColumn::DateTime](http://search.cpan.org/perldoc?DBIx::Class::InflateColumn::DateTime) and mark your column data type as
-'datetime' or similar.
+ converts it's value to a [DateTime](https://metacpan.org/pod/DateTime) object. Will use a various methods to try
+ and coerce a string, like "today", or "January 6, 1974". Makes it easier to
+ insert dates into your database without knowing or caring about the expected
+ format. For this to work correctly, you need to use the class component
+ [DBIx::Class::InflateColumn::DateTime](https://metacpan.org/pod/DBIx::Class::InflateColumn::DateTime) and mark your column data type as
+ 'datetime' or similar.
- Find
-Used for when you want the value of something that you expect already exists
-in the database (but for which you didn't just populatemore for, use 'Index'
-for that case.) Use cases for this include lookup style tables, like 'Status'
-or 'Gender', 'State', etc. which you may already have installed. This is a
-string in the form of '!Find:Source.[key1=val1,key2=val2,...'.
-
-If your find doesn't return a single result, expect an error.
-
-It's trivial to write more; please feel free to post me your contributions.
+ Used for when you want the value of something that you expect already exists
+ in the database (but for which you didn't just populatemore for, use 'Index'
+ for that case.) Use cases for this include lookup style tables, like 'Status'
+ or 'Gender', 'State', etc. which you may already have installed. This is a
+ string in the form of '!Find:Source.\[key1=val1,key2=val2,...'.
-Please note the when inserting rows, we are actually calling "create_or_update"
-on each data item, so this will not be as fast as using $schema->bulk_insert.
+ If your find doesn't return a single result, expect an error.
+ It's trivial to write more; please feel free to post me your contributions.
+Please note the when inserting rows, we are actually calling "create\_or\_update"
+on each data item, so this will not be as fast as using $schema->bulk\_insert.
# METHODS
This module defines the following methods.
-## populate_more ($ArrayRef||@Array)
+## populate\_more ($ArrayRef||@Array)
-Given an arrayref formatted as in the [SYNOPSIS](#pod_SYNOPSIS) example, populate a rows in
+Given an arrayref formatted as in the ["SYNOPSIS"](#synopsis) example, populate a rows in
a database. Confesses on errors.
We allow a few different inputs to make it less verbose to use under different
@@ -132,50 +124,50 @@ situations, as well as format nicely using your configuration format of choice.
The $ArrayRef contains one or more elements in the following pattern;
- $schema->populate_more([
- {Source1 => {
- fields => [qw/ column belongs_to has_many/],
- data => {
- key_1 => ['value', $row, \@rows ],
- }}},
- {Source2 => {
- fields => [qw/ column belongs_to has_many/],
- data => {
- key_1 => ['value', $row, \@rows ],
- }}},
- ]);
+ $schema->populate_more([
+ {Source1 => {
+ fields => [qw/ column belongs_to has_many/],
+ data => {
+ key_1 => ['value', $row, \@rows ],
+ }}},
+ {Source2 => {
+ fields => [qw/ column belongs_to has_many/],
+ data => {
+ key_1 => ['value', $row, \@rows ],
+ }}},
+ ]);
The @Array version can be one of the following:
- ## Option One
- $schema->populate_more(
- {Source1 => {
- fields => [qw/ column belongs_to has_many/],
- data => {
- key_1 => ['value', $row, \@rows ],
- }}},
- {Source2 => {
- fields => [qw/ column belongs_to has_many/],
- data => {
- key_1 => ['value', $row, \@rows ],
- }}},
- );
-
- ## Option Two
- $schema->populate_more(
- Source1 => {
- fields => [qw/ column belongs_to has_many/],
- data => {
- key_1 => ['value', $row, \@rows ],
- }
- },
- Source2 => {
- fields => [qw/ column belongs_to has_many/],
- data => {
- key_1 => ['value', $row, \@rows ],
- }
- },
- );
+ ## Option One
+ $schema->populate_more(
+ {Source1 => {
+ fields => [qw/ column belongs_to has_many/],
+ data => {
+ key_1 => ['value', $row, \@rows ],
+ }}},
+ {Source2 => {
+ fields => [qw/ column belongs_to has_many/],
+ data => {
+ key_1 => ['value', $row, \@rows ],
+ }}},
+ );
+
+ ## Option Two
+ $schema->populate_more(
+ Source1 => {
+ fields => [qw/ column belongs_to has_many/],
+ data => {
+ key_1 => ['value', $row, \@rows ],
+ }
+ },
+ Source2 => {
+ fields => [qw/ column belongs_to has_many/],
+ data => {
+ key_1 => ['value', $row, \@rows ],
+ }
+ },
+ );
The last option is probably your choice if you are building a Perl structure
directly, since it's the least verbose.
@@ -184,43 +176,43 @@ directly, since it's the least verbose.
while fields is an arrayref of either columns or named relationships and data
is a hashref of rows that you will insert into the Source.
-See [SYNOPSIS](#pod_SYNOPSIS) for more.
+See ["SYNOPSIS"](#synopsis) for more.
# ARGUMENT NOTES
-The perl structure used in [populate_more](#pod_populate_more) was designed to be reasonable
+The perl structure used in ["populate\_more"](#populate_more) was designed to be reasonable
friendly to type in most of the popular configuration formats. For example,
the above serialized to YAML would look like:
- - Gender:
- fields: label
- data:
- female: female
- male: male
- - Person:
- fields:
- - name
- - age
- - gender
- data:
- jane:
- - jane
- - 40
- - '!Index:Gender.female'
- john:
- - john
- - 38
- - !Index:Gender.male'
- - FriendList:
- fields:
- - person
- - friend
- - created_date
- data:
- john_jane:
- - '!Index:Person.john'
- - '!Index:Person.jane'
- - '!Date: March 30, 1996'
+ - Gender:
+ fields: label
+ data:
+ female: female
+ male: male
+ - Person:
+ fields:
+ - name
+ - age
+ - gender
+ data:
+ jane:
+ - jane
+ - 40
+ - '!Index:Gender.female'
+ john:
+ - john
+ - 38
+ - !Index:Gender.male'
+ - FriendList:
+ fields:
+ - person
+ - friend
+ - created_date
+ data:
+ john_jane:
+ - '!Index:Person.john'
+ - '!Index:Person.jane'
+ - '!Date: March 30, 1996'
Since the argument is an arrayref or an array, the same base result source can
appear as many times as you like. This could be useful when a second insert
@@ -235,11 +227,11 @@ John Napiorkowski, `<jjnapiork@cpan.org>`
Please report any bugs or feature requests to:
- C<bug-DBIx-Class-Schema-PopulateMore at rt.cpan.org>
+ C<bug-DBIx-Class-Schema-PopulateMore at rt.cpan.org>
or through the web interface at:
- L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=DBIx-Class-Schema-PopulateMore>
+ L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=DBIx-Class-Schema-PopulateMore>
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.
@@ -254,24 +246,24 @@ You can also look for information at:
- RT: CPAN's request tracker
-[http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBIx-Class-Schema-PopulateMore](http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBIx-Class-Schema-PopulateMore)
+ [http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBIx-Class-Schema-PopulateMore](http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBIx-Class-Schema-PopulateMore)
- AnnoCPAN: Annotated CPAN documentation
-[http://annocpan.org/dist/DBIx-Class-Schema-PopulateMore](http://annocpan.org/dist/DBIx-Class-Schema-PopulateMore)
+ [http://annocpan.org/dist/DBIx-Class-Schema-PopulateMore](http://annocpan.org/dist/DBIx-Class-Schema-PopulateMore)
- CPAN Ratings
-[http://cpanratings.perl.org/d/DBIx-Class-Schema-PopulateMore](http://cpanratings.perl.org/d/DBIx-Class-Schema-PopulateMore)
+ [http://cpanratings.perl.org/d/DBIx-Class-Schema-PopulateMore](http://cpanratings.perl.org/d/DBIx-Class-Schema-PopulateMore)
- Search CPAN
-[http://search.cpan.org/dist/DBIx-Class-Schema-PopulateMore](http://search.cpan.org/dist/DBIx-Class-Schema-PopulateMore)
+ [http://search.cpan.org/dist/DBIx-Class-Schema-PopulateMore](http://search.cpan.org/dist/DBIx-Class-Schema-PopulateMore)
# ACKNOWLEDGEMENTS
-Thanks to the entire [DBIx::Class](http://search.cpan.org/perldoc?DBIx::Class) team for providing such a useful and
-extensible ORM. Also thanks to the [Moose](http://search.cpan.org/perldoc?Moose) developers for making it fun and
+Thanks to the entire [DBIx::Class](https://metacpan.org/pod/DBIx::Class) team for providing such a useful and
+extensible ORM. Also thanks to the [Moose](https://metacpan.org/pod/Moose) developers for making it fun and
easy to write beautiful Perl.
# COPYRIGHT & LICENSE
@@ -279,4 +271,4 @@ easy to write beautiful Perl.
Copyright 2011, John Napiorkowski
This program is free software; you can redistribute it and/or modify it under
-the same terms as Perl itself.
\ No newline at end of file
+the same terms as Perl itself.
@@ -3,11 +3,12 @@ package Module::AutoInstall;
use strict;
use Cwd ();
+use File::Spec ();
use ExtUtils::MakeMaker ();
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.03';
+ $VERSION = '1.08';
}
# special map on pre-defined feature sets
@@ -17,11 +18,14 @@ my %FeatureMap = (
);
# various lexical flags
-my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
+my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS );
my (
- $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps
+ $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps,
+ $UpgradeDeps
);
-my ( $PostambleActions, $PostambleUsed );
+my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps,
+ $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps,
+ $PostambleActionsListAllDeps, $PostambleUsed, $NoTest);
# See if it's a testing or non-interactive session
_accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN );
@@ -31,6 +35,10 @@ sub _accept_default {
$AcceptDefault = shift;
}
+sub _installdeps_target {
+ $InstallDepsTarget = shift;
+}
+
sub missing_modules {
return @Missing;
}
@@ -63,6 +71,11 @@ sub _init {
__PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
exit 0;
}
+ elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) {
+ $UpgradeDeps = 1;
+ __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
+ exit 0;
+ }
elsif ( $arg =~ /^--default(?:deps)?$/ ) {
$AcceptDefault = 1;
}
@@ -125,7 +138,7 @@ sub import {
# check entirely since we don't want to have to load (and configure)
# an old CPAN just for a cosmetic message
- $UnderCPAN = _check_lock(1) unless $SkipInstall;
+ $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget;
while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
my ( @required, @tests, @skiptests );
@@ -175,7 +188,7 @@ sub import {
}
# XXX: check for conflicts and uninstalls(!) them.
- my $cur = _load($mod);
+ my $cur = _version_of($mod);
if (_version_cmp ($cur, $arg) >= 0)
{
print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
@@ -207,6 +220,7 @@ sub import {
$CheckOnly
or ($mandatory and $UnderCPAN)
or $AllDeps
+ or $InstallDepsTarget
or _prompt(
qq{==> Auto-install the }
. ( @required / 2 )
@@ -237,10 +251,17 @@ sub import {
}
}
- if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) {
+ if ( @Missing and not( $CheckOnly or $UnderCPAN) ) {
require Config;
- print
-"*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n";
+ my $make = $Config::Config{make};
+ if ($InstallDepsTarget) {
+ print
+"*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n";
+ }
+ else {
+ print
+"*** Dependencies will be installed the next time you type '$make'.\n";
+ }
# make an educated guess of whether we'll need root permission.
print " (You may need to do that as the 'root' user.)\n"
@@ -271,6 +292,10 @@ END_MESSAGE
sub _check_lock {
return unless @Missing or @_;
+ if ($ENV{PERL5_CPANM_IS_RUNNING}) {
+ return _running_under('cpanminus');
+ }
+
my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING};
if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
@@ -324,7 +349,7 @@ sub install {
while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
# grep out those already installed
- if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
+ if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) {
push @installed, $pkg;
}
else {
@@ -332,6 +357,11 @@ sub install {
}
}
+ if ($UpgradeDeps) {
+ push @modules, @installed;
+ @installed = ();
+ }
+
return @installed unless @modules; # nothing to do
return @installed if _check_lock(); # defer to the CPAN shell
@@ -363,7 +393,7 @@ sub install {
# see if we have successfully installed them
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
- if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
+ if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) {
push @installed, $pkg;
}
elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
@@ -463,6 +493,11 @@ sub _cpanplus_config {
} else {
die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n";
}
+ push @config, 'prereqs', $value;
+ } elsif ( $key eq 'force' ) {
+ push @config, $key, $value;
+ } elsif ( $key eq 'notest' ) {
+ push @config, 'skiptest', $value;
} else {
die "*** Cannot convert option $key to CPANPLUS version.\n";
}
@@ -497,10 +532,14 @@ sub _install_cpan {
# set additional options
while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) {
( $args{$opt} = $arg, next )
- if $opt =~ /^force$/; # pseudo-option
+ if $opt =~ /^(?:force|notest)$/; # pseudo-option
$CPAN::Config->{$opt} = $arg;
}
+ if ($args{notest} && (not CPAN::Shell->can('notest'))) {
+ die "Your version of CPAN is too old to support the 'notest' pragma";
+ }
+
local $CPAN::Config->{prerequisites_policy} = 'follow';
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
@@ -519,8 +558,16 @@ sub _install_cpan {
delete $INC{$inc};
}
- my $rv = $args{force} ? CPAN::Shell->force( install => $pkg )
- : CPAN::Shell->install($pkg);
+ my $rv = do {
+ if ($args{force}) {
+ CPAN::Shell->force( install => $pkg )
+ } elsif ($args{notest}) {
+ CPAN::Shell->notest( install => $pkg )
+ } else {
+ CPAN::Shell->install($pkg)
+ }
+ };
+
$rv ||= eval {
$CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, )
->{install}
@@ -575,7 +622,7 @@ sub _update_to {
my $ver = shift;
return
- if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade
+ if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade
if (
_prompt( "==> A newer version of $class ($ver) is required. Install?",
@@ -660,16 +707,30 @@ sub _can_write {
# load a module and return the version it reports
sub _load {
- my $mod = pop; # class/instance doesn't matter
+ my $mod = pop; # method/function doesn't matter
my $file = $mod;
-
$file =~ s|::|/|g;
$file .= '.pm';
-
local $@;
return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 );
}
+# report version without loading a module
+sub _version_of {
+ my $mod = pop; # method/function doesn't matter
+ my $file = $mod;
+ $file =~ s|::|/|g;
+ $file .= '.pm';
+ foreach my $dir ( @INC ) {
+ next if ref $dir;
+ my $path = File::Spec->catfile($dir, $file);
+ next unless -e $path;
+ require ExtUtils::MM_Unix;
+ return ExtUtils::MM_Unix->parse_version($path);
+ }
+ return undef;
+}
+
# Load CPAN.pm and it's configuration
sub _load_cpan {
return if $CPAN::VERSION and $CPAN::Config and not @_;
@@ -763,6 +824,35 @@ sub _make_args {
: "\$(NOECHO) \$(NOOP)"
);
+ my $deps_list = join( ',', @Missing, @Existing );
+
+ $PostambleActionsUpgradeDeps =
+ "\$(PERL) $0 --config=$config --upgradedeps=$deps_list";
+
+ my $config_notest =
+ join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}),
+ 'notest', 1 )
+ if $Config;
+
+ $PostambleActionsNoTest = (
+ ($missing and not $UnderCPAN)
+ ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing"
+ : "\$(NOECHO) \$(NOOP)"
+ );
+
+ $PostambleActionsUpgradeDepsNoTest =
+ "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list";
+
+ $PostambleActionsListDeps =
+ '@$(PERL) -le "print for @ARGV" '
+ . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing);
+
+ my @all = (@Missing, @Existing);
+
+ $PostambleActionsListAllDeps =
+ '@$(PERL) -le "print for @ARGV" '
+ . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all);
+
return %args;
}
@@ -797,11 +887,15 @@ sub Write {
sub postamble {
$PostambleUsed = 1;
+ my $fragment;
- return <<"END_MAKE";
+ $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget;
config :: installdeps
\t\$(NOECHO) \$(NOOP)
+AUTO_INSTALL
+
+ $fragment .= <<"END_MAKE";
checkdeps ::
\t\$(PERL) $0 --checkdeps
@@ -809,12 +903,28 @@ checkdeps ::
installdeps ::
\t$PostambleActions
+installdeps_notest ::
+\t$PostambleActionsNoTest
+
+upgradedeps ::
+\t$PostambleActionsUpgradeDeps
+
+upgradedeps_notest ::
+\t$PostambleActionsUpgradeDepsNoTest
+
+listdeps ::
+\t$PostambleActionsListDeps
+
+listalldeps ::
+\t$PostambleActionsListAllDeps
+
END_MAKE
+ return $fragment;
}
1;
__END__
-#line 1071
+#line 1193
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.08';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -73,6 +73,17 @@ sub auto_install {
);
}
+sub installdeps_target {
+ my ($self, @args) = @_;
+
+ $self->include('Module::AutoInstall');
+ require Module::AutoInstall;
+
+ Module::AutoInstall::_installdeps_target(1);
+
+ $self->auto_install(@args);
+}
+
sub auto_install_now {
my $self = shift;
$self->auto_install(@_);
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.08';
}
# Suspend handler for "redefined" warnings
@@ -3,13 +3,12 @@ package Module::Install::Can;
use strict;
use Config ();
-use File::Spec ();
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.08';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -29,7 +28,7 @@ sub can_use {
eval { require $mod; $pkg->VERSION($ver || 0); 1 };
}
-# check if we can run some command
+# Check if we can run some command
sub can_run {
my ($self, $cmd) = @_;
@@ -38,14 +37,88 @@ sub can_run {
for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
next if $dir eq '';
- my $abs = File::Spec->catfile($dir, $_[1]);
+ require File::Spec;
+ my $abs = File::Spec->catfile($dir, $cmd);
return $abs if (-x $abs or $abs = MM->maybe_command($abs));
}
return;
}
-# can we locate a (the) C compiler
+# 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;
my @chunks = split(/ /, $Config::Config{cc}) or return;
@@ -78,4 +151,4 @@ if ( $^O eq 'cygwin' ) {
__END__
-#line 156
+#line 236
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.08';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.08';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -8,7 +8,7 @@ use Fcntl qw/:flock :seek/;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.08';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -215,18 +215,22 @@ sub write {
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 );
+ # 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.42 );
- $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
+ $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 );
}
# Generate the MakeMaker params
@@ -241,7 +245,6 @@ in a module, and provide its file path via 'version_from' (or
'all_from' if you prefer) in Makefile.PL.
EOT
- $DB::single = 1;
if ( $self->tests ) {
my @tests = split ' ', $self->tests;
my %seen;
@@ -412,4 +415,4 @@ sub postamble {
__END__
-#line 541
+#line 544
@@ -1,16 +1,26 @@
#line 1
+##
+# name: Module::Install::ManifestSkip
+# abstract: Generate a MANIFEST.SKIP file
+# author: Ingy döt Net <ingy@cpan.org>
+# license: perl
+# copyright: 2010, 2011
+# see:
+# - Module::Manifest::Skip
+
package Module::Install::ManifestSkip;
+use 5.008001;
use strict;
use warnings;
-use 5.008003;
-use Module::Install::Base;
+use base 'Module::Install::Base';
-use vars qw($VERSION @ISA);
-BEGIN {
- $VERSION = '0.14';
- @ISA = 'Module::Install::Base';
-}
+my $requires = "
+use Module::Manifest::Skip 0.10 ();
+";
+
+our $VERSION = '0.20';
+our $AUTHOR_ONLY = 1;
my $skip_file = "MANIFEST.SKIP";
@@ -18,67 +28,21 @@ sub manifest_skip {
my $self = shift;
return unless $self->is_admin;
- print "manifest_skip\n";
+ eval $requires; die $@ if $@;
+
+ print "Writing $skip_file\n";
- my $keepers;
- if (-e $skip_file) {
- open IN, $skip_file
- or die "Can't open $skip_file for input: $!";
- my $input = do {local $/; <IN>};
- close IN;
- if ($input =~ s/(.*?\n)\s*\n.*/$1/s and $input =~ /\S/) {
- $keepers = $input;
- }
- }
open OUT, '>', $skip_file
or die "Can't open $skip_file for output: $!";;
- if ($keepers) {
- print OUT "$keepers\n";
- }
-
- print OUT _skip_files();
+ print OUT Module::Manifest::Skip->new->text;
close OUT;
$self->clean_files('MANIFEST');
-}
-
-sub _skip_files {
- return <<'...';
-^Makefile$
-^Makefile\.old$
-^pm_to_blib$
-^blib/
-^pod2htm.*
-^MANIFEST\.SKIP$
-^MANIFEST\.bak$
-^\.git/
-^\.gitignore
-^\.gitmodules
-/\.git/
-\.svn/
-^\.vimrc$
-\.sw[op]$
-^core$
-^out$
-^tmon.out$
-^\w$
-^foo.*
-^notes
-^todo
-^ToDo$
-## avoid OS X finder files
-\.DS_Store$
-## skip komodo project files
-\.kpf$
-## ignore emacs and vim backup files
-~$
-...
+ $self->clean_files($skip_file)
+ if grep /^clean$/, @_;
}
1;
-=encoding utf8
-
-#line 135
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.08';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -151,15 +151,21 @@ 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\n";
- return $self;
+ 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} = $_[0] ? 1 : 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 @_;
@@ -170,7 +176,7 @@ sub perl_version {
# Normalize the version
$version = $self->_perl_version($version);
- # We don't support the reall old versions
+ # 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";
}
@@ -582,7 +588,7 @@ sub bugtracker_from {
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;
+ my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.08';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.08';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
@@ -31,7 +31,7 @@ BEGIN {
# 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.01';
+ $VERSION = '1.08';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -451,7 +451,7 @@ sub _version ($) {
}
sub _cmp ($$) {
- _version($_[0]) <=> _version($_[1]);
+ _version($_[1]) <=> _version($_[2]);
}
# Cloned from Params::Util::_CLASS
@@ -467,4 +467,4 @@ sub _CLASS ($) {
1;
-# Copyright 2008 - 2011 Adam Kennedy.
+# Copyright 2008 - 2012 Adam Kennedy.
@@ -1,236 +1,882 @@
#line 1
+# vim: set ts=2 sts=2 sw=2 expandtab smarttab:
+#
+# This file is part of Pod-Markdown
+#
+# This software is copyright (c) 2004 by Marcel Gruenauer.
+#
+# This is free software; you can redistribute it and/or modify it under
+# the same terms as the Perl 5 programming language system itself.
+#
use 5.008;
use strict;
use warnings;
package Pod::Markdown;
+# git description: v2.000-3-ga15fde1
+$Pod::Markdown::VERSION = '2.001';
BEGIN {
- $Pod::Markdown::VERSION = '1.110730';
+ $Pod::Markdown::AUTHORITY = 'cpan:RWSTAUNER';
}
# ABSTRACT: Convert POD to Markdown
-use parent qw(Pod::Parser);
-sub initialize {
- my $self = shift;
- $self->SUPER::initialize(@_);
- $self->_private;
- $self;
+use Pod::Simple 3.14 (); # external links with text
+use parent qw(Pod::Simple::Methody);
+
+our %URL_PREFIXES = (
+ sco => 'http://search.cpan.org/perldoc?',
+ metacpan => 'https://metacpan.org/pod/',
+ man => 'http://man.he.net/man',
+);
+$URL_PREFIXES{perldoc} = $URL_PREFIXES{metacpan};
+
+
+sub new {
+ my $class = shift;
+ my %args = @_;
+
+ my $self = $class->SUPER::new();
+ $self->preserve_whitespace(1);
+ $self->accept_targets(qw( markdown html ));
+
+ my $data = $self->_private;
+ while( my ($attr, $val) = each %args ){
+ $data->{ $attr } = $val;
+ }
+
+ for my $type ( qw( perldoc man ) ){
+ my $attr = $type . '_url_prefix';
+ # Use provided argument or default alias.
+ my $url = $self->$attr || $type;
+ # Expand alias if defined (otherwise use url as is).
+ $data->{ $attr } = $URL_PREFIXES{ $url } || $url;
+ }
+
+ $self->_prepare_fragment_formats;
+
+ return $self;
}
+## Attribute accessors ##
+
+
+my @attr = qw(
+ man_url_prefix
+ perldoc_url_prefix
+ perldoc_fragment_format
+ markdown_fragment_format
+ include_meta_tags
+);
+
+{
+ no strict 'refs'; ## no critic
+ foreach my $attr ( @attr ){
+ *$attr = sub { return $_[0]->_private->{ $attr } };
+ }
+}
+
+sub _prepare_fragment_formats {
+ my ($self) = @_;
+
+ foreach my $attr ( @attr ){
+ next unless $attr =~ /^(\w+)_fragment_format/;
+ my $type = $1;
+ my $format = $self->$attr;
+
+ # If one was provided.
+ if( $format ){
+ # If the attribute is a coderef just use it.
+ next if ref($format) eq 'CODE';
+ }
+ # Else determine a default.
+ else {
+ if( $type eq 'perldoc' ){
+ # Choose a default that matches the destination url.
+ my $target = $self->perldoc_url_prefix;
+ foreach my $alias ( qw( metacpan sco ) ){
+ if( $target eq $URL_PREFIXES{ $alias } ){
+ $format = $alias;
+ }
+ }
+ # This seems like a reasonable fallback.
+ $format ||= 'pod_simple_xhtml';
+ }
+ else {
+ $format = $type;
+ }
+ }
+
+ # The short name should become a method name with the prefix prepended.
+ my $prefix = 'format_fragment_';
+ $format =~ s/^$prefix//;
+ die "Unknown fragment format '$format'"
+ unless $self->can($prefix . $format);
+
+ # Save it.
+ $self->_private->{ $attr } = $format;
+ }
+
+ return;
+}
+
+## Backward compatible API ##
+
+# For backward compatibility (previously based on Pod::Parser):
+# While Pod::Simple provides a parse_from_file() method
+# it's primarily for Pod::Parser compatibility.
+# When called without an output handle it will print to STDOUT
+# but the old Pod::Markdown never printed to a handle
+# so we don't want to start now.
+sub parse_from_file {
+ my ($self, $file) = @_;
+ $self->output_string(\($self->{_as_markdown_}));
+ $self->parse_file($file);
+}
+
+# Likewise, though Pod::Simple doesn't define this method at all.
+sub parse_from_filehandle { shift->parse_from_file(@_) }
+
+
+## Document state ##
+
sub _private {
- my $self = shift;
- $self->{_MyParser} ||= {
- Text => [], # final text
- Indent => 0, # list indent levels counter
- ListType => '-', # character on every item
- searching => '' , # what are we searching for? (title, author etc.)
- Title => undef, # page title
- Author => undef, # page author
- };
+ my ($self) = @_;
+ $self->{_Pod_Markdown_} ||= {
+ indent => 0,
+ stacks => [],
+ states => [{}],
+ link => [],
+ };
+}
+
+sub _increase_indent {
+ ++$_[0]->_private->{indent} >= 1
+ or die 'Invalid state: indent < 0';
+}
+sub _decrease_indent {
+ --$_[0]->_private->{indent} >= 0
+ or die 'Invalid state: indent < 0';
+}
+
+sub _new_stack {
+ push @{ $_[0]->_private->{stacks} }, [];
+ push @{ $_[0]->_private->{states} }, {};
+}
+
+sub _last_string {
+ $_[0]->_private->{stacks}->[-1][-1];
+}
+
+sub _pop_stack_text {
+ $_[0]->_private->{last_state} = pop @{ $_[0]->_private->{states} };
+ join '', @{ pop @{ $_[0]->_private->{stacks} } };
+}
+
+sub _stack_state {
+ $_[0]->_private->{states}->[-1];
+}
+
+sub _save {
+ my ($self, $text) = @_;
+ push @{ $self->_private->{stacks}->[-1] }, $text;
+ # return $text; # DEBUG
+}
+
+sub _save_line {
+ my ($self, $text) = @_;
+ $self->_save($text . $/);
+}
+
+# For paragraphs, etc.
+sub _save_block {
+ my ($self, $text) = @_;
+
+ $self->_stack_state->{blocks}++;
+
+ $self->_save_line($self->_indent($text) . $/);
}
+## Formatting ##
+
+sub _chomp_all {
+ my ($self, $text) = @_;
+ 1 while chomp $text;
+ return $text;
+}
+
+sub _indent {
+ my ($self, $text) = @_;
+ my $level = $self->_private->{indent};
+
+ if( $level ){
+ my $indent = ' ' x ($level * 4);
+
+ # Capture text on the line so that we don't indent blank lines (/^\x20{4}$/).
+ $text =~ s/^(.+)/$indent$1/mg;
+ }
+
+ return $text;
+}
+
+
sub as_markdown {
my ($parser, %args) = @_;
- my $data = $parser->_private;
- my $lines = $data->{Text};
my @header;
- if ($args{with_meta}) {
+ # Don't add meta tags again if we've already done it.
+ if( $args{with_meta} && !$parser->include_meta_tags ){
@header = $parser->_build_markdown_head;
}
- join("\n" x 2, @header, @{$lines});
+ return join("\n" x 2, @header, $parser->{_as_markdown_});
}
sub _build_markdown_head {
my $parser = shift;
my $data = $parser->_private;
- my $paragraph = '';
- if (defined $data->{Title}) {
- $paragraph .= sprintf '[[meta title="%s"]]', $data->{Title};
+ return join "\n",
+ map { qq![[meta \l$_="$data->{$_}"]]! }
+ grep { defined $data->{$_} }
+ qw( Title Author );
+}
+
+## Escaping ##
+
+# http://daringfireball.net/projects/markdown/syntax#backslash
+# Markdown provides backslash escapes for the following characters:
+#
+# \ backslash
+# ` backtick
+# * asterisk
+# _ underscore
+# {} curly braces
+# [] square brackets
+# () parentheses
+# # hash mark
+# + plus sign
+# - minus sign (hyphen)
+# . dot
+# ! exclamation mark
+
+# However some of those only need to be escaped in certain places:
+# * Backslashes *do* need to be escaped or they may be swallowed by markdown.
+# * Word-surrounding characters (/[`*_]/) *do* need to be escaped mid-word
+# because the markdown spec explicitly allows mid-word em*pha*sis.
+# * I don't actually see anything that curly braces are used for.
+# * Escaping square brackets is enough to avoid accidentally
+# creating links and images (so we don't need to escape plain parentheses
+# or exclamation points as that would generate a lot of unnecesary noise).
+# Parentheses will be escaped in urls (&end_L) to avoid premature termination.
+# * We don't need a backslash for every hash mark or every hyphen found mid-word,
+# just the ones that start a line (likewise for plus and dot).
+# (Those will all be handled by _escape_paragraph_markdown).
+
+# Backslash escape markdown characters to avoid having them interpreted.
+sub _escape_inline_markdown {
+ local $_ = $_[1];
+
+# s/([\\`*_{}\[\]()#+-.!])/\\$1/g; # See comments above.
+ s/([\\`*_\[\]])/\\$1/g;
+
+ return $_;
+}
+
+# Escape markdown characters that would be interpreted
+# at the start of a line.
+sub _escape_paragraph_markdown {
+ local $_ = $_[1];
+
+ # Escape headings, horizontal rules, (unordered) lists, and blockquotes.
+ s/^([-+#>])/\\$1/mg;
+
+ # Markdown doesn't support backslash escapes for equal signs
+ # even though they can be used to underline a header.
+ # So use html to escape them to avoid having them interpreted.
+ s/^([=])/sprintf '&#x%x;', ord($1)/mge;
+
+ # Escape the dots that would wrongfully create numbered lists.
+ s/^( (?:>\s+)? \d+ ) (\.\x20)/$1\\$2/xgm;
+
+ return $_;
+}
+
+## Parsing ##
+
+sub handle_text {
+ my ($self, $text) = @_;
+
+ # Markdown is for html, so use html entities.
+ $text =~ s/ / /g
+ if $self->_private->{nbsp};
+
+ # Unless we're in a code span or verbatim block.
+ unless( $self->_private->{no_escape} ){
+
+ # We could, in theory, alter what gets escaped according to context
+ # (for example, escape square brackets (but not parens) inside link text).
+ # The markdown produced might look slightly nicer but either way you're
+ # at the whim of the markdown processor to interpret things correctly.
+ # For now just escape everything.
+
+ # Don't let literal characters be interpreted as markdown.
+ $text = $self->_escape_inline_markdown($text);
+
+ }
+
+ $self->_save($text);
+}
+
+sub start_Document {
+ my ($self) = @_;
+ $self->_new_stack;
+}
+
+sub end_Document {
+ my ($self) = @_;
+ $self->_check_search_header;
+ my $end = pop @{ $self->_private->{stacks} };
+
+ @{ $self->_private->{stacks} } == 0
+ or die 'Document ended with stacks remaining';
+
+ my @doc = $self->_chomp_all(join('', @$end)) . $/;
+
+ if( $self->include_meta_tags ){
+ unshift @doc, $self->_build_markdown_head, ($/ x 2);
+ }
+
+ print { $self->{output_fh} } @doc;
+}
+
+## Blocks ##
+
+sub start_Verbatim {
+ my ($self) = @_;
+ $self->_new_stack;
+ $self->_private->{no_escape} = 1;
+}
+
+sub end_Verbatim {
+ my ($self) = @_;
+
+ my $text = $self->_pop_stack_text;
+
+ $text = $self->_indent_verbatim($text);
+
+ $self->_private->{no_escape} = 0;
+
+ # Verbatim blocks do not generate a separate "Para" event.
+ $self->_save_block($text);
+}
+
+sub _indent_verbatim {
+ my ($self, $paragraph) = @_;
+
+ # NOTE: Pod::Simple expands the tabs for us (as suggested by perlpodspec).
+ # Pod::Simple also has a 'strip_verbatim_indent' attribute
+ # but it doesn't sound like it gains us anything over this method.
+
+ # POD verbatim can start with any number of spaces (or tabs)
+ # markdown should be 4 spaces (or a tab)
+ # so indent any paragraphs so that all lines start with at least 4 spaces
+ my @lines = split /\n/, $paragraph;
+ my $indent = ' ' x 4;
+ foreach my $line ( @lines ){
+ next unless $line =~ m/^( +)/;
+ # find the smallest indentation
+ $indent = $1 if length($1) < length($indent);
}
- if (defined $data->{Author}) {
- $paragraph .= "\n" . sprintf '[[meta author="%s"]]', $data->{Author};
+ if( (my $smallest = length($indent)) < 4 ){
+ # invert to get what needs to be prepended
+ $indent = ' ' x (4 - $smallest);
+
+ # Prepend indent to each line.
+ # We could check /\S/ to only indent non-blank lines,
+ # but it's backward compatible to respect the whitespace.
+ # Additionally, both pod and markdown say they ignore blank lines
+ # so it shouldn't hurt to leave them in.
+ $paragraph = join "\n", map { length($_) ? $indent . $_ : '' } @lines;
}
- return $paragraph;
+
+ return $paragraph;
}
-sub _save {
- my ($parser, $text) = @_;
- my $data = $parser->_private;
- $text = $parser->_indent_text($text);
- push @{ $data->{Text} }, $text;
- return;
+sub start_Para {
+ $_[0]->_new_stack;
}
-sub _unsave {
- my $parser = shift;
- my $data = $parser->_private;
- return pop @{ $data->{Text} };
+sub end_Para {
+ my ($self) = @_;
+ my $text = $self->_pop_stack_text;
+
+ $text = $self->_escape_paragraph_markdown($text);
+
+ $self->_save_block($text);
}
-sub _indent_text {
- my ($parser, $text) = @_;
- my $data = $parser->_private;
- my $level = $data->{Indent};
- my $indent = undef;
- if ($level > 0) {
- $level--;
+
+## Headings ##
+
+sub start_head1 { $_[0]->_start_head(1) }
+sub end_head1 { $_[0]->_end_head(1) }
+sub start_head2 { $_[0]->_start_head(2) }
+sub end_head2 { $_[0]->_end_head(2) }
+sub start_head3 { $_[0]->_start_head(3) }
+sub end_head3 { $_[0]->_end_head(3) }
+sub start_head4 { $_[0]->_start_head(4) }
+sub end_head4 { $_[0]->_end_head(4) }
+
+sub _check_search_header {
+ my ($self) = @_;
+ # Save the text since the last heading if we want it for metadata.
+ if( my $last = $self->_private->{search_header} ){
+ for( $self->_private->{$last} = $self->_last_string ){
+ s/\A\s+//;
+ s/\s+\z//;
}
- $indent = ' ' x ($level * 4);
- my @lines = map { $indent . $_; } split(/\n/, $text);
- return wantarray ? @lines : join("\n", @lines);
+ }
}
+sub _start_head {
+ my ($self) = @_;
+ $self->_check_search_header;
+ $self->_new_stack;
+}
+
+sub _end_head {
+ my ($self, $num) = @_;
+ my $h = '#' x $num;
-sub _clean_text {
- my $text = $_[1];
- my @trimmed = grep { $_; } split(/\n/, $text);
- return wantarray ? @trimmed : join("\n", @trimmed);
+ my $text = $self->_pop_stack_text;
+ $self->_private->{search_header} =
+ $text =~ /NAME/ ? 'Title'
+ : $text =~ /AUTHOR/ ? 'Author'
+ : undef;
+
+ # TODO: option for $h suffix
+ # TODO: put a name="" if $self->{embed_anchor_tags}; ?
+ # https://rt.cpan.org/Ticket/Display.html?id=57776
+ $self->_save_block(join(' ', $h, $text));
}
-sub command {
- my ($parser, $command, $paragraph, $line_num) = @_;
- my $data = $parser->_private;
+## Lists ##
- # cleaning the text
- $paragraph = $parser->_clean_text($paragraph);
+# TODO: over_empty
- # is it a header ?
- if ($command =~ m{head(\d)}xms) {
- my $level = $1;
+sub _start_list {
+ my ($self) = @_;
+ $self->_new_stack;
- $paragraph = $parser->interpolate($paragraph, $line_num);
+ # Nest again b/c start_item will pop this to look for preceding content.
+ $self->_increase_indent;
+ $self->_new_stack;
+}
- # the headers never are indented
- $parser->_save($parser->format_header($level, $paragraph));
- if ($level == 1) {
- if ($paragraph =~ m{NAME}xmsi) {
- $data->{searching} = 'title';
- } elsif ($paragraph =~ m{AUTHOR}xmsi) {
- $data->{searching} = 'author';
- } else {
- $data->{searching} = '';
- }
- }
+sub _end_list {
+ my ($self) = @_;
+ $self->_handle_between_item_content;
+
+ # Finish the list.
+
+ # All the child elements should be blocks,
+ # but don't end with a double newline.
+ my $text = $self->_chomp_all($self->_pop_stack_text);
+
+ # FIXME:
+ $_[0]->_save_line($text . $/);
+}
+
+sub _handle_between_item_content {
+ my ($self) = @_;
+
+ # This might be empty (if the list item had no additional content).
+ if( my $text = $self->_pop_stack_text ){
+ # Else it's a sub-document.
+ # If there are blocks we need to separate with blank lines.
+ if( $self->_private->{last_state}->{blocks} ){
+ $text = $/ . $text;
}
+ # If not, we can condense the text.
+ # In this module's history there was a patch contributed to specifically
+ # produce "huddled" lists so we'll try to maintain that functionality.
+ else {
+ $text = $self->_chomp_all($text) . $/;
+ }
+ $self->_save($text)
+ }
- # opening a list ?
- elsif ($command =~ m{over}xms) {
+ $self->_decrease_indent;
+}
- # update indent level
- $data->{Indent}++;
+sub _start_item {
+ my ($self) = @_;
+ $self->_handle_between_item_content;
+ $self->_new_stack;
+}
- # closing a list ?
- } elsif ($command =~ m{back}xms) {
+sub _end_item {
+ my ($self, $marker) = @_;
+ $self->_save_line($self->_indent($marker . ' ' . $self->_pop_stack_text));
- # decrement indent level
- $data->{Indent}--;
- $data->{searching} = '';
- } elsif ($command =~ m{item}xms) {
- $paragraph = $parser->interpolate($paragraph, $line_num);
- $paragraph =~ s{^\h* \* \h*}{}xms;
+ # Store any possible contents in a new stack (like a sub-document).
+ $self->_increase_indent;
+ $self->_new_stack;
+}
- if ($data->{searching} eq 'listpara') {
- $data->{searching} = 'listheadhuddled';
- }
- else {
- $data->{searching} = 'listhead';
- }
+sub start_over_bullet { $_[0]->_start_list }
+sub end_over_bullet { $_[0]->_end_list }
- if (length $paragraph) {
- $parser->textblock($paragraph, $line_num);
- }
- }
+sub start_item_bullet { $_[0]->_start_item }
+sub end_item_bullet { $_[0]->_end_item('-') }
+
+sub start_over_number { $_[0]->_start_list }
+sub end_over_number { $_[0]->_end_list }
+
+sub start_item_number {
+ $_[0]->_start_item;
+ # It seems like this should be a stack,
+ # but from testing it appears that the corresponding 'end' event
+ # comes right after the text (it doesn't surround any embedded content).
+ # See t/nested.t which shows start-item, text, end-item, para, start-item....
+ $_[0]->_private->{item_number} = $_[1]->{number};
+}
+
+sub end_item_number {
+ my ($self) = @_;
+ $self->_end_item($self->_private->{item_number} . '.');
+}
+
+# Markdown doesn't support definition lists
+# so do regular (unordered) lists with indented paragraphs.
+sub start_over_text { $_[0]->_start_list }
+sub end_over_text { $_[0]->_end_list }
+
+sub start_item_text { $_[0]->_start_item }
+sub end_item_text { $_[0]->_end_item('-')}
+
+
+# perlpodspec equates an over/back region with no items to a blockquote.
+sub start_over_block {
+ # NOTE: We don't actually need to indent for a blockquote.
+ $_[0]->_new_stack;
+}
+
+sub end_over_block {
+ my ($self) = @_;
+
+ # Chomp first to avoid prefixing a blank line with a `>`.
+ my $text = $self->_chomp_all($self->_pop_stack_text);
+
+ # NOTE: Paragraphs will already be escaped.
+
+ # I don't really like either of these implementations
+ # but the join/map/split seems a little better and benches a little faster.
+ # You would lose the last newline but we've already chomped.
+ #$text =~ s{^(.)?}{'>' . (defined($1) && length($1) ? (' ' . $1) : '')}mge;
+ $text = join $/, map { length($_) ? '> ' . $_ : '>' } split qr-$/-, $text;
+
+ $self->_save_block($text);
+}
+
+## Custom Formats ##
+
+sub start_for {
+ my ($self, $attr) = @_;
+ $self->_new_stack;
+
+ if( $attr->{target} eq 'html' ){
+ # Use another stack so we can indent
+ # (not syntactily necessary but seems appropriate).
+ $self->_new_stack;
+ $self->_increase_indent;
+ $self->_private->{no_escape} = 1;
+ # Mark this so we know to undo it.
+ $self->_stack_state->{for_html} = 1;
+ }
+}
+
+sub end_for {
+ my ($self) = @_;
+ # Data gets saved as a block (which will handle indents),
+ # but if there was html we'll alter this, so chomp and save a block again.
+ my $text = $self->_chomp_all($self->_pop_stack_text);
+
+ if( $self->_private->{last_state}->{for_html} ){
+ $self->_private->{no_escape} = 0;
+ # Save it to the next stack up so we can pop it again (we made two stacks).
+ $self->_save($text);
+ $self->_decrease_indent;
+ $text = join "\n", '<div>', $self->_chomp_all($self->_pop_stack_text), '</div>';
+ }
+
+ $self->_save_block($text);
+}
+
+# Data events will be emitted for any formatted regions that have been enabled
+# (by default, `markdown` and `html`).
+
+sub start_Data {
+ my ($self) = @_;
+ # TODO: limit this to what's in attr?
+ $self->_private->{no_escape}++;
+ $self->_new_stack;
+}
+
+sub end_Data {
+ my ($self) = @_;
+ my $text = $self->_pop_stack_text;
+ $self->_private->{no_escape}--;
+ $self->_save_block($text);
+}
+
+## Codes ##
+
+sub start_B { $_[0]->_save('**') }
+sub end_B { $_[0]->start_B() }
+
+sub start_I { $_[0]->_save('_') }
+sub end_I { $_[0]->start_I() }
- # ignore other commands
+sub start_C {
+ my ($self) = @_;
+ $self->_new_stack;
+ $self->_private->{no_escape}++;
+}
+
+sub end_C {
+ my ($self) = @_;
+ $self->_private->{no_escape}--;
+ $self->_save( $self->_wrap_code_span($self->_pop_stack_text) );
+}
+
+# Use code spans for F<>.
+sub start_F { shift->start_C(@_); }
+sub end_F { shift ->end_C(@_); }
+
+sub start_S { $_[0]->_private->{nbsp}++; }
+sub end_S { $_[0]->_private->{nbsp}--; }
+
+sub start_L {
+ my ($self, $flags) = @_;
+ $self->_new_stack;
+ push @{ $self->_private->{link} }, $flags;
+}
+
+sub end_L {
+ my ($self) = @_;
+ my $flags = pop @{ $self->_private->{link} }
+ or die 'Invalid state: link end with no link start';
+
+ my ($type, $to, $section) = @{$flags}{qw( type to section )};
+
+ my $url = (
+ $type eq 'url' ? $to
+ : $type eq 'man' ? $self->format_man_url($to, $section)
+ : $type eq 'pod' ? $self->format_perldoc_url($to, $section)
+ : undef
+ );
+
+ my $text = $self->_pop_stack_text;
+
+ # NOTE: I don't think the perlpodspec says what to do with L<|blah>
+ # but it seems like a blank link text just doesn't make sense
+ if( !length($text) ){
+ $text =
+ $section ?
+ $to ? sprintf('"%s" in %s', $section, $to)
+ : ('"' . $section . '"')
+ : $to;
+ }
+
+ # FIXME: What does Pod::Simple::X?HTML do for this?
+ # if we don't know how to handle the url just print the pod back out
+ if (!$url) {
+ $self->_save(sprintf 'L<%s>', $flags->{raw});
return;
+ }
+
+ # In the url we need to escape quotes and parentheses lest markdown
+ # break the url (cut it short and/or wrongfully interpret a title).
+
+ # Backslash escapes do not work for the space and quotes.
+ # URL-encoding the space is not sufficient
+ # (the quotes confuse some parsers and produce invalid html).
+ # I've arbitratily chosen HTML encoding to hide them from markdown
+ # while mangling the url as litle as possible.
+ $url =~ s/([ '"])/sprintf '&#x%x;', ord($1)/ge;
+
+ # We also need to double any backslashes that may be present
+ # (lest they be swallowed up) and stop parens from breaking the url.
+ $url =~ s/([\\()])/\\$1/g;
+
+ # TODO: put section name in title if not the same as $text
+ $self->_save('[' . $text . '](' . $url . ')');
}
-sub verbatim {
- my ($parser, $paragraph) = @_;
- $parser->_save($paragraph);
+sub start_X {
+ $_[0]->_new_stack;
}
-sub textblock {
- my ($parser, $paragraph, $line_num) = @_;
- my $data = $parser->_private;
+sub end_X {
+ my ($self) = @_;
+ my $text = $self->_pop_stack_text;
+ # TODO: mangle $text?
+ # TODO: put <a name="$text"> if configured
+}
- # interpolate the paragraph for embebed sequences
- $paragraph = $parser->interpolate($paragraph, $line_num);
+# A code span can be delimited by multiple backticks (and a space)
+# similar to pod codes (C<< code >>), so ensure we use a big enough
+# delimiter to not have it broken by embedded backticks.
+sub _wrap_code_span {
+ my ($self, $arg) = @_;
+ my $longest = 0;
+ while( $arg =~ /([`]+)/g ){
+ my $len = length($1);
+ $longest = $len if $longest < $len;
+ }
+ my $delim = '`' x ($longest + 1);
+ my $pad = $longest > 0 ? ' ' : '';
+ return $delim . $pad . $arg . $pad . $delim;
+}
- # clean the empty lines
- $paragraph = $parser->_clean_text($paragraph);
+## Link Formatting (TODO: Move this to another module) ##
- # searching ?
- if ($data->{searching} =~ m{title|author}xms) {
- $data->{ ucfirst $data->{searching} } = $paragraph;
- $data->{searching} = '';
- } elsif ($data->{searching} =~ m{listhead(huddled)?$}xms) {
- my $is_huddled = $1;
- $paragraph = sprintf '%s %s', $data->{ListType}, $paragraph;
- if ($is_huddled) {
- $paragraph = $parser->_unsave() . "\n" . $paragraph;
- }
- $data->{searching} = 'listpara';
- } elsif ($data->{searching} eq 'listpara') {
- $data->{searching} = '';
- }
- # save the text
- $parser->_save($paragraph);
-}
-
-sub interior_sequence {
- my ($seq_command, $seq_argument, $pod_seq) = @_[1..3];
- my %interiors = (
- 'I' => sub { return '_' . $_[1] . '_' }, # italic
- 'B' => sub { return '__' . $_[1] . '__' }, # bold
- 'C' => sub { return '`' . $_[1] . '`' }, # monospace
- 'F' => sub { return '`' . $_[1] . '`' }, # system path
- 'S' => sub { return '`' . $_[1] . '`' }, # code
- 'E' => sub {
- my $charname = $_[1];
- return '<' if $charname eq 'lt';
- return '>' if $charname eq 'gt';
- return '|' if $charname eq 'verbar';
- return '/' if $charname eq 'sol';
- return "&$charname;";
- },
- 'L' => \&_resolv_link,
- );
- if (exists $interiors{$seq_command}) {
- my $code = $interiors{$seq_command};
- return $code->($seq_command, $seq_argument, $pod_seq);
- } else {
- return sprintf '%s<%s>', $seq_command, $seq_argument;
- }
+sub format_man_url {
+ my ($self, $to) = @_;
+ my ($page, $part) = ($to =~ /^ ([^(]+) (?: \( (\S+) \) )? /x);
+ return $self->man_url_prefix . ($part || 1) . '/' . ($page || $to);
}
-sub _resolv_link {
- my ($cmd, $arg) = @_;
- my $text = $arg =~ s"^(.+?)\|"" ? $1 : '';
-
- if ($arg =~ m{^http|ftp}xms) { # direct link to a URL
- $text ||= $arg;
- return sprintf '[%s](%s)', $text, $arg;
- } elsif ($arg =~ m{^/(.*)$}) {
- $text ||= $1;
- $text = $1;
- return "[$text](\#pod_$1)";
- } elsif ($arg =~ m{^(\w+(?:::\w+)*)$}) {
- $text ||= $1;
- return "[$text](http://search.cpan.org/perldoc?$1)";
- } else {
- return sprintf '%s<%s>', $cmd, $arg;
+
+sub format_perldoc_url {
+ my ($self, $name, $section) = @_;
+
+ my $url_prefix = $self->perldoc_url_prefix;
+ my $url = '';
+
+ # If the link is to another module (external link).
+ if ($name) {
+ $url = $url_prefix . $name;
+ }
+
+ # See https://rt.cpan.org/Ticket/Display.html?id=57776
+ # for a discussion on the need to mangle the section.
+ if ($section){
+
+ my $method = $url
+ # If we already have a prefix on the url it's external.
+ ? $self->perldoc_fragment_format
+ # Else an internal link points to this markdown doc.
+ : $self->markdown_fragment_format;
+
+ $method = 'format_fragment_' . $method
+ unless ref($method);
+
+ {
+ # Set topic to enable code refs to be simple.
+ local $_ = $section;
+ $section = $self->$method($section);
}
+
+ $url .= '#' . $section;
+ }
+
+ return $url;
}
-sub format_header {
- my ($level, $paragraph) = @_[1,2];
- sprintf '%s %s', '#' x $level, $paragraph;
+
+# TODO: simple, pandoc, etc?
+
+sub format_fragment_markdown {
+ my ($self, $section) = @_;
+
+ # If this is an internal link (to another section in this doc)
+ # we can't be sure what the heading id's will look like
+ # (it depends on what is rendering the markdown to html)
+ # but we can try to follow popular conventions.
+
+ # http://johnmacfarlane.net/pandoc/demo/example9/pandocs-markdown.html#header-identifiers-in-html-latex-and-context
+ #$section =~ s/(?![-_.])[[:punct:]]//g;
+ #$section =~ s/\s+/-/g;
+ $section =~ s/\W+/-/g;
+ $section =~ s/-+$//;
+ $section =~ s/^-+//;
+ $section = lc $section;
+ #$section =~ s/^[^a-z]+//;
+ $section ||= 'section';
+
+ return $section;
}
-1;
+{
+ # From Pod::Simple::XHTML 3.28.
+ # The strings gets passed through encode_entities() before idify().
+ # If we don't do it here the substitutions below won't operate consistently.
+
+ # encode_entities {
+ my %entities = (
+ q{>} => 'gt',
+ q{<} => 'lt',
+ q{'} => '#39',
+ q{"} => 'quot',
+ q{&} => 'amp',
+ );
+
+ my
+ $ents = join '', keys %entities;
+ # }
+
+ sub format_fragment_pod_simple_xhtml {
+ my ($self, $t) = @_;
+
+ # encode_entities {
+ $t =~ s/([$ents])/'&' . ($entities{$1} || sprintf '#x%X', ord $1) . ';'/ge;
+ # }
+
+ # idify {
+ for ($t) {
+ s/<[^>]+>//g; # Strip HTML.
+ s/&[^;]+;//g; # Strip entities.
+ s/^\s+//; s/\s+$//; # Strip white space.
+ s/^([^a-zA-Z]+)$/pod$1/; # Prepend "pod" if no valid chars.
+ s/^[^a-zA-Z]+//; # First char must be a letter.
+ s/[^-a-zA-Z0-9_:.]+/-/g; # All other chars must be valid.
+ s/[-:.]+$//; # Strip trailing punctuation.
+ }
+ # }
+
+ return $t;
+ }
+}
+
+
+sub format_fragment_pod_simple_html {
+ my ($self, $section) = @_;
+
+ # From Pod::Simple::HTML 3.28.
+
+ # section_name_tidy {
+ $section =~ s/^\s+//;
+ $section =~ s/\s+$//;
+ $section =~ tr/ /_/;
+ $section =~ tr/\x00-\x1F\x80-\x9F//d if 'A' eq chr(65); # drop crazy characters
+
+ #$section = $self->unicode_escape_url($section);
+ # unicode_escape_url {
+ $section =~ s/([^\x00-\xFF])/'('.ord($1).')'/eg;
+ # Turn char 1234 into "(1234)"
+ # }
+
+ $section = '_' unless length $section;
+ return $section;
+ # }
+}
+
+
+sub format_fragment_metacpan { shift->format_fragment_pod_simple_xhtml(@_); }
+sub format_fragment_sco { shift->format_fragment_pod_simple_html(@_); }
+
+1;
__END__
-#line 341
+#line 1263
@@ -1,11 +1,13 @@
package DBIx::Class::Schema::PopulateMore::Command;
-use Moose;
+use Moo;
+use MooX::HandlesVia;
use List::MoreUtils qw(pairwise);
use DBIx::Class::Schema::PopulateMore::Visitor;
use Module::Pluggable::Object;
-use Moose::Util::TypeConstraints qw(class_type);
-
+use Type::Library -base;
+use Types::Standard -types;
+use namespace::clean;
=head1 NAME
@@ -28,10 +30,10 @@ This is the Schema we are populating
=cut
-has 'schema' => (
+has schema => (
is=>'ro',
required=>1,
- isa=>'Object',
+ isa=>Object,
);
=head2 exception_cb
@@ -40,10 +42,10 @@ contains a callback to the exception method supplied by DBIC
=cut
-has 'exception_cb' => (
+has exception_cb => (
is=>'ro',
required=>1,
- isa=>'CodeRef',
+ isa=>CodeRef,
);
=head2 definitions
@@ -52,11 +54,10 @@ This is an arrayref of information used to populate tables in the database
=cut
-has 'definitions' => (
+has definitions => (
is=>'ro',
required=>1,
- isa=>"ArrayRef[HashRef]",
- auto_deref=>1,
+ isa=>ArrayRef[HashRef],
);
@@ -67,10 +68,10 @@ on. This get's the namespace of the substitution plugin and it's other data.
=cut
-has 'match_condition' => (
+has match_condition => (
is=>'ro',
required=>1,
- isa=>'RegexpRef',
+ isa=>RegexpRef,
default=>sub {qr/^!(\w+:.+)$/ },
);
@@ -83,10 +84,9 @@ neater
=cut
-has 'visitor' => (
- is=>'ro',
- isa=>'DBIx::Class::Schema::PopulateMore::Visitor',
- lazy_build=>1,
+has visitor => (
+ is=>'lazy',
+ isa=>InstanceOf['DBIx::Class::Schema::PopulateMore::Visitor'],
handles => [
'callback',
'visit',
@@ -112,11 +112,10 @@ given an index, returns the related inflated resultset
=cut
-has 'rs_index' => (
- traits=>['Hash'],
+has rs_index => (
is=>'rw',
- isa=>'HashRef[Object]',
- lazy=>1,
+ handles_via=>'Hash',
+ isa=>HashRef[Object],
default=>sub { +{} },
handles=> {
set_rs_index => 'set',
@@ -131,10 +130,9 @@ Loads each of the available inflators, provider access to the objects
=cut
-has 'inflator_loader' => (
- is=>'ro',
- isa=> class_type('Module::Pluggable::Object'),
- lazy_build=>1,
+has inflator_loader => (
+ is=>'lazy',
+ isa=>InstanceOf['Module::Pluggable::Object'],
handles=>{
'inflators' => 'plugins',
},
@@ -147,14 +145,13 @@ Holds an object that can perform dispatching to the inflators.
=cut
-has 'inflator_dispatcher' => (
- traits=>['Hash'],
- is=>'rw',
- isa=>'HashRef[Object]',
- lazy_build=>1,
+has inflator_dispatcher => (
+ is=>'lazy',
+ handles_via=>'Hash',
+ isa=>HashRef[Object],
handles=>{
inflator_list => 'keys',
- 'get_inflator' => 'get',
+ get_inflator => 'get',
},
);
@@ -232,9 +229,9 @@ sub execute
{
my ($self) = @_;
- foreach my $definition ($self->definitions)
+ foreach my $definition (@{$self->definitions})
{
- my ($source, $info) = each %$definition;
+ my ($source => $info) = %$definition;
my @fields = $self->coerce_to_array($info->{fields});
my $data = $self
@@ -1,6 +1,6 @@
package DBIx::Class::Schema::PopulateMore::Inflator::Date;
-use Moose;
+use Moo;
use DateTimeX::Easy;
extends 'DBIx::Class::Schema::PopulateMore::Inflator';
@@ -1,6 +1,6 @@
package DBIx::Class::Schema::PopulateMore::Inflator::Env;
-use Moose;
+use Moo;
extends 'DBIx::Class::Schema::PopulateMore::Inflator';
=head1 NAME
@@ -1,6 +1,6 @@
package DBIx::Class::Schema::PopulateMore::Inflator::Find;
-use Moose;
+use Moo;
extends 'DBIx::Class::Schema::PopulateMore::Inflator';
=head1 NAME
@@ -1,6 +1,6 @@
package DBIx::Class::Schema::PopulateMore::Inflator::Index;
-use Moose;
+use Moo;
extends 'DBIx::Class::Schema::PopulateMore::Inflator';
=head1 NAME
@@ -1,6 +1,6 @@
package DBIx::Class::Schema::PopulateMore::Inflator;
-use Moose;
+use Moo;
=head1 NAME
@@ -8,7 +8,7 @@ DBIx::Class::Schema::PopulateMore::Inflator - Base Class for keyword Inflators
=head1 DESCRIPTION
-When L<DBIx::Class::Schema::PopulateMore::Command> executes, it uses a vistor object
+When L<DBIx::Class::Schema::PopulateMore::Command> executes, it uses a visitor object
(see L<DBIx::Class::Schema::PopulateMore::Visitor> to descend the key values of the
data hash that is used to put stuff into the given tables. If it finds a value
that matches a particular regexp, that means the value needs to be inflated and
@@ -66,7 +66,7 @@ __PACKAGE__
=head2 employee
-The person that is employeed by a company
+The person that is employed by a company
=cut
@@ -1,7 +1,10 @@
package DBIx::Class::Schema::PopulateMore::Visitor;
-use Moose;
-extends 'Data::Visitor';
+use Moo;
+use Scalar::Util qw/refaddr/;
+use Type::Library -base;
+use Types::Standard -types;
+use namespace::clean;
=head1 NAME
@@ -38,7 +41,7 @@ has 'update_callback' => (
is=>'rw',
required=>1,
lazy=>1,
- isa=>'CodeRef',
+ isa=>CodeRef,
default=> sub {
return sub {
return shift;
@@ -59,9 +62,20 @@ inflate to resultset. This is the most common usecase.
has 'match_condition' => (
is=>'ro',
required=>1,
- isa=>'RegexpRef'
+ isa=>RegexpRef,
);
+=head2 seen
+
+Used to collect up ref addresses of arrays/hashes we have already seen
+
+=cut
+
+has seen => (
+ is => 'rw',
+ isa => HashRef,
+ default => sub { {} },
+);
=head1 METHODS
@@ -80,11 +94,37 @@ sub callback
return $self;
}
+=head2 visit
+
+A simple visitor that only expects to perform replacements on values
+
+=cut
+
+sub visit
+{
+ my ( $self, $target ) = @_;
+ if ( ref $target eq 'ARRAY' ) {
+ my $addr = refaddr $target;
+ return $self->seen->{$addr} if defined $self->seen->{$addr};
+ my $new_array = $self->seen->{$addr} = [];
+ @$new_array = map { $self->visit($_) } @$target;
+ return $new_array;
+ }
+ elsif ( ref $target eq 'HASH' ) {
+ my $addr = refaddr $target;
+ return $self->seen->{$addr} if defined $self->seen->{$addr};
+ my $new_hash = $self->seen->{$addr} = {};
+ %$new_hash = map { $_ => $self->visit( $target->{$_} ) } keys %$target;
+ return $new_hash;
+ }
+ else {
+ $self->visit_value($target);
+ }
+}
=head2 visit_value
-Overload from the base case L<Data::Visitor> Here is where we make the choice
-as to if this value needs to be inflated via a plugin
+Here is where we make the choice as to if this value needs to be inflated via a plugin
=cut
@@ -103,7 +143,7 @@ sub visit_value
=head2 match_or_not
-We break this out to handle the uglyness surrounding dealing with undef values
+We break this out to handle the ugliness surrounding dealing with undef values
and also to make it easier on subclassers.
=cut
@@ -130,6 +170,8 @@ sub match_or_not
Please see L<DBIx::Class::Schema::PopulateMore> For authorship information
+visit method culled from code in L<Data::Visitor::Lite> which is copyright 2011 Daichi Hiroki <hirokidaichi {at} gmail.com>
+
=head1 LICENSE
Please see L<DBIx::Class::Schema::PopulateMore> For licensing terms.
@@ -16,7 +16,7 @@ Version 0.17
=cut
-our $VERSION = '0.17';
+our $VERSION = '0.18';
=head1 SYNOPSIS
@@ -93,7 +93,7 @@ This distribution supplies three expansion commands:
Use for creating relationships. This is a string in the form of "Source.Label"
where the Source is the name of the result source that you are creating rows in
-and Label is a key name from from key part of the data hash.
+and Label is a key name from the key part of the data hash.
=item Env
@@ -1,7 +1,7 @@
use warnings;
use strict;
-use Test::More tests => 40;
+use Test::More tests => 43;
use DBIx::Class::Schema::PopulateMore::Test::Schema;
ok my $schema = DBIx::Class::Schema::PopulateMore::Test::Schema->connect_and_setup
@@ -202,6 +202,14 @@ ok my $joe = $schema->resultset('Person')->search({name=>'joe'})->first,
is $joe->age, 19, 'Joe is 19';
+ok $joe->delete, 'Delete Joe';
+
+ok my %index2_again = $schema->populate_more($extra)
+ => 'Successful populated same data again.';
+
+ok my $joe_again = $schema->resultset('Person')->search({name=>'joe'})->first,
+ => 'Got a Person again';
+
ok my %index3 = $schema->populate_more(
Gender => {
fields => 'label',