@@ -1,5 +1,9 @@
This file documents the revision history for Perl extension Test-DBIx-Class.
+0.42 13 Aug 2014
+ - Fixed issue where a resultset isn't properly 'reset'
+ - documentation improvements
+
0.41 21 Jan 2014
- Change Moose load_class() (now deprecated) to Module::Runtime use_module()
@@ -63,6 +63,7 @@ t/14-hide-diag.t
t/14-test-connection-opts.t
t/15-hide-diag-mysqld.t
t/16-hide-diag-postgres.t
+t/17-importing-sources-gives-new-resultset.t
t/etc/example/fixtures/core.pl
t/etc/example/fixtures/more.pl
t/etc/example/schema.pl
@@ -4,12 +4,12 @@ author:
- 'John Napiorkowski C<< <jjnapiork@cpan.org> >>'
build_requires:
ExtUtils::MakeMaker: 6.59
- Test::More: 0.94
+ Test::More: '0.94'
configure_requires:
ExtUtils::MakeMaker: 6.59
distribution_type: module
dynamic_config: 1
-generated_by: 'Module::Install version 1.06'
+generated_by: 'Module::Install version 1.10'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -21,32 +21,32 @@ no_index:
- inc
- t
requires:
- Config::Any: 0.19
- DBIx::Class: 0.08123
- DBIx::Class::Schema::PopulateMore: 0.16
- DBIx::Class::TimeStamp: 0.13
- DBIx::Class::UUIDColumns: 0.02005
- Data::UUID: 1.215
- Data::Visitor: 0.27
+ Config::Any: '0.19'
+ DBIx::Class: '0.08123'
+ DBIx::Class::Schema::PopulateMore: '0.16'
+ DBIx::Class::TimeStamp: '0.13'
+ DBIx::Class::UUIDColumns: '0.02005'
+ Data::UUID: '1.215'
+ Data::Visitor: '0.27'
DateTime::Format::Pg: 0
- Digest::MD5: 2.39
+ Digest::MD5: '2.39'
File::Path: 0
File::Temp: 0
- Hash::Merge: 0.11
- List::MoreUtils: 0.22
- Module::Runtime: 0.013
- Moose: 1.10
- MooseX::Attribute::ENV: 0.01
- MooseX::Types: 0.23
- Path::Class: 0.21
- SQL::Translator: 0.11006
- Scalar::Util: 1.23
- Sub::Exporter: 0.982
- Test::Builder: 0.96
- Test::Deep: 0.106
+ Hash::Merge: '0.11'
+ List::MoreUtils: '0.22'
+ Module::Runtime: '0.013'
+ Moose: '1.10'
+ MooseX::Attribute::ENV: '0.01'
+ MooseX::Types: '0.23'
+ Path::Class: '0.21'
+ SQL::Translator: '0.11006'
+ Scalar::Util: '1.23'
+ Sub::Exporter: '0.982'
+ Test::Builder: '0.96'
+ Test::Deep: '0.106'
perl: 5.8.0
resources:
homepage: http://search.cpan.org/dist/Test-DBIx-Class/
license: http://dev.perl.org/licenses/
repository: git://github.com/jjn1056/Test-DBIx-Class.git
-version: 0.41
+version: '0.42'
@@ -83,7 +83,6 @@ such as:
'Same test as above, just different compare format;
-
is_fields [qw/job_title salary/], $john->jobs, [
['programmer', 100000],
['administrator, 120000],
@@ -152,8 +151,6 @@ The following methods are automatically imported when you use this module.
You probably won't need this directly in your tests unless you have some
application logic methods in it.
-
-
## ResultSet ($source, ?{%search}, ?{%conditions})
Although you can import your sources as local keywords, sometimes you might
@@ -529,6 +526,7 @@ This code reference gets passed the resultset object. So you can use any
method on $resultset. For example:
'Person' => {exec => sub { shift->find('john') }, -as => 'John'};
+
is_result John;
is John->name, 'John Napiorkowski', "Got Correct Name";
@@ -8,7 +8,7 @@ use ExtUtils::MakeMaker ();
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.10';
}
# special map on pre-defined feature sets
@@ -115,7 +115,7 @@ sub import {
print "*** $class version " . $class->VERSION . "\n";
print "*** Checking for Perl dependencies...\n";
- my $cwd = Cwd::cwd();
+ my $cwd = Cwd::getcwd();
$Config = [];
@@ -166,7 +166,7 @@ sub import {
$modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' );
unshift @$modules, -default => &{ shift(@$modules) }
- if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability
+ if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward compatibility
while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) {
if ( $mod =~ m/^-(\w+)$/ ) {
@@ -345,22 +345,26 @@ sub install {
my $i; # used below to strip leading '-' from config keys
my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } );
- my ( @modules, @installed );
- while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
+ my ( @modules, @installed, @modules_to_upgrade );
+ while (my ($pkg, $ver) = splice(@_, 0, 2)) {
- # grep out those already installed
- if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) {
- push @installed, $pkg;
- }
- else {
- push @modules, $pkg, $ver;
- }
- }
+ # grep out those already installed
+ if (_version_cmp(_version_of($pkg), $ver) >= 0) {
+ push @installed, $pkg;
+ if ($UpgradeDeps) {
+ push @modules_to_upgrade, $pkg, $ver;
+ }
+ }
+ else {
+ push @modules, $pkg, $ver;
+ }
+ }
- if ($UpgradeDeps) {
- push @modules, @installed;
- @installed = ();
- }
+ if ($UpgradeDeps) {
+ push @modules, @modules_to_upgrade;
+ @installed = ();
+ @modules_to_upgrade = ();
+ }
return @installed unless @modules; # nothing to do
return @installed if _check_lock(); # defer to the CPAN shell
@@ -611,7 +615,7 @@ sub _under_cpan {
require Cwd;
require File::Spec;
- my $cwd = File::Spec->canonpath( Cwd::cwd() );
+ my $cwd = File::Spec->canonpath( Cwd::getcwd() );
my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} );
return ( index( $cwd, $cpan ) > -1 );
@@ -927,4 +931,4 @@ END_MAKE
__END__
-#line 1193
+#line 1197
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.10';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -91,3 +91,7 @@ sub auto_install_now {
}
1;
+
+__END__
+
+#line 109
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.10';
}
# Suspend handler for "redefined" warnings
@@ -8,7 +8,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.10';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.10';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -91,3 +91,7 @@ END_FTP
}
1;
+
+__END__
+
+#line 109
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.10';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -32,3 +32,7 @@ sub auto_include_dependent_dists {
}
1;
+
+__END__
+
+#line 50
@@ -8,7 +8,7 @@ use Fcntl qw/:flock :seek/;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.10';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -133,7 +133,7 @@ sub makemaker_args {
return $args;
}
-# For mm args that take multiple space-seperated args,
+# For mm args that take multiple space-separated args,
# append an argument to the current list.
sub makemaker_append {
my $self = shift;
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.10';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -347,7 +347,7 @@ sub name_from {
^ \s*
package \s*
([\w:]+)
- \s* ;
+ [\s|;]*
/ixms
) {
my ($name, $module_name) = ($1, $1);
@@ -453,24 +453,40 @@ sub author_from {
#Stolen from M::B
my %license_urls = (
- perl => 'http://dev.perl.org/licenses/',
- apache => 'http://apache.org/licenses/LICENSE-2.0',
- apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
- 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,
+
+## from Software-License - should we be using S-L instead ?
+# duplicates commeted out, see hack above ^^
+# open_source => 'http://www.gnu.org/licenses/agpl-3.0.txt',
+# apache => 'http://www.apache.org/licenses/LICENSE-1.1',
+ apache => 'http://www.apache.org/licenses/LICENSE-2.0.txt',
+ artistic => 'http://www.perlfoundation.org/artistic_license_1_0',
+ artistic_2 => 'http://www.perlfoundation.org/artistic_license_2_0',
+ bsd => 'http://opensource.org/licenses/BSD-3-Clause',
+# unrestricted => 'http://creativecommons.org/publicdomain/zero/1.0/',
+# open_source => 'http://www.freebsd.org/copyright/freebsd-license.html',
+# open_source => 'http://www.gnu.org/licenses/fdl-1.2.txt',
+# open_source => 'http://www.gnu.org/licenses/fdl-1.3.txt',
+# gpl => 'http://www.gnu.org/licenses/old-licenses/gpl-1.0.txt',
+# gpl => 'http://www.gnu.org/licenses/old-licenses/gpl-2.0.txt',
+ gpl => 'http://www.gnu.org/licenses/gpl-3.0.txt',
+# lgpl => 'http://www.gnu.org/licenses/old-licenses/lgpl-2.1.txt',
+ lgpl => 'http://www.gnu.org/licenses/lgpl-3.0.txt',
+ mit => 'http://www.opensource.org/licenses/mit-license.php',
+# mozilla => 'http://www.mozilla.org/MPL/MPL-1.0.txt',
+# mozilla => 'http://www.mozilla.org/MPL/MPL-1.1.txt',
+ mozilla => 'http://www.mozilla.org/MPL/2.0/index.txt',
+# restrictive => '',
+# open_source => 'http://www.openssl.org/source/license.html',
+ perl => 'http://dev.perl.org/licenses/',
+# open_source => 'http://www.opensource.org/licenses/postgresql',
+# open_source => 'http://trolltech.com/products/qt/licenses/licensing/qpl',
+# unrestricted => 'http://h71000.www7.hp.com/doc/83final/BA554_90007/apcs02.html',
+# open_source => 'http://www.openoffice.org/licenses/sissl_license.html',
+# open_source => 'http://www.zlib.net/zlib_license.html',
);
sub license {
@@ -511,31 +527,43 @@ sub __extract_license {
my @phrases = (
'(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1,
'(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
- 'Artistic and GPL' => 'perl', 1,
- 'GNU general public license' => 'gpl', 1,
- 'GNU public license' => 'gpl', 1,
- 'GNU lesser general public license' => 'lgpl', 1,
- 'GNU lesser public license' => 'lgpl', 1,
- 'GNU library general public license' => 'lgpl', 1,
- 'GNU library public license' => 'lgpl', 1,
- 'GNU Free Documentation license' => 'unrestricted', 1,
- 'GNU Affero General Public License' => 'open_source', 1,
+
+ # the following are relied on by the test system even if they are wrong :(
'(?:Free)?BSD license' => 'bsd', 1,
'Artistic license 2\.0' => 'artistic_2', 1,
- 'Artistic license' => 'artistic', 1,
- 'Apache (?:Software )?license' => 'apache', 1,
- 'GPL' => 'gpl', 1,
'LGPL' => 'lgpl', 1,
- 'BSD' => 'bsd', 1,
- 'Artistic' => 'artistic', 1,
'MIT' => 'mit', 1,
- 'Mozilla Public License' => 'mozilla', 1,
- 'Q Public License' => 'open_source', 1,
- 'OpenSSL License' => 'unrestricted', 1,
- 'SSLeay License' => 'unrestricted', 1,
- 'zlib License' => 'open_source', 1,
- 'proprietary' => 'proprietary', 0,
+
+## from Software-License
+ 'The GNU Affero General Public License, Version 3, November 2007' => 'open_source', 1,
+ 'The Apache Software License, Version 1.1' => 'apache', 1,
+ 'The Apache License, Version 2.0, January 2004' => 'apache', 1,
+ 'The Artistic License 1.0' => 'artistic', 1,
+ 'The Artistic License 2.0 (GPL Compatible)' => 'artistic_2', 1,
+ 'The (three-clause) BSD License' => 'bsd', 1,
+ 'CC0 License' => 'unrestricted', 1,
+ 'The (two-clause) FreeBSD License' => 'open_source', 1,
+ 'GNU Free Documentation License v1.2' => 'open_source', 1,
+ 'GNU Free Documentation License v1.3' => 'open_source', 1,
+ 'The GNU General Public License, Version 1, February 1989' => 'gpl', 1,
+ 'The GNU General Public License, Version 2, June 1991' => 'gpl', 1,
+ 'The GNU General Public License, Version 3, June 2007' => 'gpl', 1,
+ 'The GNU Lesser General Public License, Version 2.1, February 1999' => 'lgpl', 1,
+ 'The GNU Lesser General Public License, Version 3, June 2007' => 'lgpl', 1,
+ 'The MIT (X11) License' => 'mit', 1,
+ 'The Mozilla Public License 1.0' => 'mozilla', 1,
+ 'The Mozilla Public License 1.1' => 'mozilla', 1,
+ 'Mozilla Public License Version 2.0' => 'mozilla', 1,
+ '"No License" License' => 'restrictive', 1,
+ 'OpenSSL License' => 'open_source', 1,
+ 'the same terms as the perl 5 programming language system itself' => 'perl', 1,
+ 'The PostgreSQL License' => 'open_source', 1,
+ 'The Q Public License, Version 1.0' => 'open_source', 1,
+ 'Original SSLeay License' => 'unrestricted', 1,
+ 'Sun Internet Standards Source License (SISSL)' => 'open_source', 1,
+ 'The zlib License' => 'open_source', 1,
);
+
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
$pattern =~ s#\s+#\\s+#gs;
if ( $license_text =~ /\b$pattern\b/i ) {
@@ -705,7 +733,7 @@ sub _write_mymeta_data {
my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
my $meta = $yaml[0];
- # Overwrite the non-configure dependency hashs
+ # Overwrite the non-configure dependency hashes
delete $meta->{requires};
delete $meta->{build_requires};
delete $meta->{recommends};
@@ -720,3 +748,7 @@ sub _write_mymeta_data {
}
1;
+
+__END__
+
+#line 766
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.10';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -62,3 +62,7 @@ END_MESSAGE
}
1;
+
+__END__
+
+#line 80
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.10';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
@@ -61,3 +61,7 @@ sub WriteAll {
}
1;
+
+__END__
+
+#line 79
@@ -17,7 +17,7 @@ package Module::Install;
# 3. The ./inc/ version of Module::Install loads
# }
-use 5.005;
+use 5.006;
use strict 'vars';
use Cwd ();
use File::Find ();
@@ -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.06';
+ $VERSION = '1.10';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -156,10 +156,10 @@ END_DIE
sub autoload {
my $self = shift;
my $who = $self->_caller;
- my $cwd = Cwd::cwd();
+ my $cwd = Cwd::getcwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
- my $pwd = Cwd::cwd();
+ my $pwd = Cwd::getcwd();
if ( my $code = $sym->{$pwd} ) {
# Delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
@@ -239,7 +239,7 @@ sub new {
# 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 ) {
+ unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) {
delete $args{prefix};
}
return $args{_self} if $args{_self};
@@ -338,7 +338,7 @@ sub find_extensions {
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
my $content = Module::Install::_read($subpath . '.pm');
my $in_pod = 0;
- foreach ( split //, $content ) {
+ foreach ( split /\n/, $content ) {
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/); # skip pod text
@@ -434,7 +434,7 @@ END_OLD
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
-sub _version ($) {
+sub _version {
my $s = shift || 0;
my $d =()= $s =~ /(\.)/g;
if ( $d >= 2 ) {
@@ -450,12 +450,12 @@ sub _version ($) {
return $l + 0;
}
-sub _cmp ($$) {
+sub _cmp {
_version($_[1]) <=> _version($_[2]);
}
# Cloned from Params::Util::_CLASS
-sub _CLASS ($) {
+sub _CLASS {
(
defined $_[0]
and
@@ -467,4 +467,7 @@ sub _CLASS ($) {
1;
-# Copyright 2008 - 2012 Adam Kennedy.
+
+__END__
+
+#line 485
@@ -13,19 +13,15 @@ use strict;
use warnings;
package Pod::Markdown;
-{
- $Pod::Markdown::VERSION = '1.500';
-}
-# git description: v1.401-20-g3999377
-
+# git description: v2.001-2-gadb8327
+$Pod::Markdown::VERSION = '2.002';
BEGIN {
$Pod::Markdown::AUTHORITY = 'cpan:RWSTAUNER';
}
# ABSTRACT: Convert POD to Markdown
-use Pod::Parser 1.51 ();
-use parent qw(Pod::Parser);
-use Pod::ParseLink (); # core
+use Pod::Simple 3.14 (); # external links with text
+use parent qw(Pod::Simple::Methody);
our %URL_PREFIXES = (
sco => 'http://search.cpan.org/perldoc?',
@@ -35,38 +31,47 @@ our %URL_PREFIXES = (
$URL_PREFIXES{perldoc} = $URL_PREFIXES{metacpan};
-# new() is provided by Pod::Parser (which calls initialize()).
+sub new {
+ my $class = shift;
+ my %args = @_;
-sub initialize {
- my $self = shift;
- $self->SUPER::initialize(@_);
+ 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;
+ my $url = $self->$attr || $type;
# Expand alias if defined (otherwise use url as is).
- $self->{ $attr } = $URL_PREFIXES{ $url } || $url;
+ $data->{ $attr } = $URL_PREFIXES{ $url } || $url;
}
$self->_prepare_fragment_formats;
- $self->_private;
- $self;
+ 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]->{ $attr } };
+ *$attr = sub { return $_[0]->_private->{ $attr } };
}
}
@@ -76,7 +81,7 @@ sub _prepare_fragment_formats {
foreach my $attr ( @attr ){
next unless $attr =~ /^(\w+)_fragment_format/;
my $type = $1;
- my $format = $self->{ $attr };
+ my $format = $self->$attr;
# If one was provided.
if( $format ){
@@ -87,7 +92,7 @@ sub _prepare_fragment_formats {
else {
if( $type eq 'perldoc' ){
# Choose a default that matches the destination url.
- my $target = $self->{perldoc_url_prefix};
+ my $target = $self->perldoc_url_prefix;
foreach my $alias ( qw( metacpan sco ) ){
if( $target eq $URL_PREFIXES{ $alias } ){
$format = $alias;
@@ -108,35 +113,120 @@ sub _prepare_fragment_formats {
unless $self->can($prefix . $format);
# Save it.
- $self->{ $attr } = $format;
+ $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.)
- sstack => [] , # Stack for searching, needed for nested list
- 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}) . "\n";
+ return join("\n" x 2, @header, $parser->{_as_markdown_});
}
sub _build_markdown_head {
@@ -148,144 +238,141 @@ sub _build_markdown_head {
qw( Title Author );
}
-# $prelisthead:
-# undef : not list head
-# '' : list head not huddled
-# otherwise: list head huddled
-sub _save {
- my ($parser, $text, $prelisthead) = @_;
- my $data = $parser->_private;
- $text = $parser->_indent_text($text, defined($prelisthead));
- $text = $prelisthead."\n".$text if defined $prelisthead && $prelisthead ne '';
- push @{ $data->{Text} }, $text;
- return;
-}
+## Escaping ##
-sub _unsave {
- my $parser = shift;
- my $data = $parser->_private;
- return pop @{ $data->{Text} };
-}
+# 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).
-sub _indent_text {
- my ($parser, $text, $listhead) = @_;
- my $data = $parser->_private;
- my $level = $data->{Indent};
- --$level if $listhead;
- my $indent = undef;
- $indent = ' ' x ($level * 4);
- my @lines = map { $indent . $_; } split(/\n/, $text);
- return wantarray ? @lines : join("\n", @lines);
-}
+# Backslash escape markdown characters to avoid having them interpreted.
+sub _escape_inline_markdown {
+ local $_ = $_[1];
-sub _clean_text {
- my $text = $_[1];
- my @trimmed = grep { $_; } split(/\n/, $text);
+# s/([\\`*_{}\[\]()#+-.!])/\\$1/g; # See comments above.
+ s/([\\`*_\[\]])/\\$1/g;
- return wantarray ? @trimmed : join("\n", @trimmed);
+ return $_;
}
-# Backslash escape markdown characters to avoid having them interpreted.
-sub _escape {
+# Escape markdown characters that would be interpreted
+# at the start of a line.
+sub _escape_paragraph_markdown {
local $_ = $_[1];
- # do inline characters first
- s/([][\\`*_#])/\\$1/g;
+ # Escape headings, horizontal rules, (unordered) lists, and blockquotes.
+ s/^([-+#>])/\\$1/mg;
- # escape 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 dots that would wrongfully create numbered lists
+ # Escape the dots that would wrongfully create numbered lists.
s/^( (?:>\s+)? \d+ ) (\.\x20)/$1\\$2/xgm;
return $_;
}
-# Formats a header according to the given level.
-sub format_header {
- my ($self, $level, $paragraph) = @_;
- # TODO: put a name="" if $self->{embed_anchor_tags}; ?
- # https://rt.cpan.org/Ticket/Display.html?id=57776
- sprintf '%s %s', '#' x $level, $paragraph;
-}
+## Parsing ##
-# Handles POD command paragraphs, denoted by a line beginning with C<=>.
-sub command {
- my ($parser, $command, $paragraph, $line_num) = @_;
- my $data = $parser->_private;
+sub handle_text {
+ my ($self, $text) = @_;
- # cleaning the text
- $paragraph = $parser->_clean_text($paragraph);
+ # Markdown is for html, so use html entities.
+ $text =~ s/ / /g
+ if $self->_private->{nbsp};
- # is it a header ?
- if ($command =~ m{head(\d)}xms) {
- my $level = $1;
+ # Unless we're in a code span or verbatim block.
+ unless( $self->_private->{no_escape} ){
- $paragraph = $parser->_escape_and_interpolate($paragraph, $line_num);
+ # 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.
- # 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} = '';
- }
- }
- }
+ # Don't let literal characters be interpreted as markdown.
+ $text = $self->_escape_inline_markdown($text);
- # opening a list ?
- elsif ($command =~ m{over}xms) {
+ }
+
+ $self->_save($text);
+}
- # update indent level
- $data->{Indent}++;
- push @{$data->{sstack}}, $data->{searching};
+sub start_Document {
+ my ($self) = @_;
+ $self->_new_stack;
+}
- # closing a list ?
- } elsif ($command =~ m{back}xms) {
+sub end_Document {
+ my ($self) = @_;
+ $self->_check_search_header;
+ my $end = pop @{ $self->_private->{stacks} };
- # decrement indent level
- $data->{Indent}--;
- $data->{searching} = pop @{$data->{sstack}};
+ @{ $self->_private->{stacks} } == 0
+ or die 'Document ended with stacks remaining';
- } elsif ($command =~ m{item}xms) {
- # this strips the POD list head; the searching=listhead will insert markdown's
- # FIXME: this does not account for named lists
+ my @doc = $self->_chomp_all(join('', @$end)) . $/;
- # Assuming that POD is correctly wrtitten, we just use POD list head as markdown's
- $data->{ListType} = '-'; # Default
- if($paragraph =~ m{^[ \t]* \* [ \t]*}xms) {
- $paragraph =~ s{^[ \t]* \* [ \t]*}{}xms;
- } elsif($paragraph =~ m{^[ \t]* (\d+)\.? [ \t]*}xms) {
- $data->{ListType} = $1.'.'; # For numbered list only
- $paragraph =~ s{^[ \t]* \d+\.? [ \t]*}{}xms;
- }
+ if( $self->include_meta_tags ){
+ unshift @doc, $self->_build_markdown_head, ($/ x 2);
+ }
- if ($data->{searching} eq 'listpara') {
- $data->{searching} = 'listheadhuddled';
- }
- else {
- $data->{searching} = 'listhead';
- }
+ print { $self->{output_fh} } @doc;
+}
- if (length $paragraph) {
- $parser->textblock($paragraph, $line_num);
- }
- }
+## Blocks ##
- # ignore other commands
- return;
+sub start_Verbatim {
+ my ($self) = @_;
+ $self->_new_stack;
+ $self->_private->{no_escape} = 1;
}
-# Handles verbatim text.
-sub verbatim {
- my ($parser, $paragraph) = @_;
+sub end_Verbatim {
+ my ($self) = @_;
+
+ my $text = $self->_pop_stack_text;
- # NOTE: perlpodspec says parsers should expand tabs by default
- # NOTE: Apparently Pod::Parser does not. should we?
- # NOTE: this might be s/^\t/" " x 8/e, but what about tabs inside the para?
+ $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)
@@ -300,168 +387,345 @@ sub verbatim {
if( (my $smallest = length($indent)) < 4 ){
# invert to get what needs to be prepended
$indent = ' ' x (4 - $smallest);
- # leave tabs alone
- $paragraph = join "\n", map { /^\t/ ? $_ : $indent . $_ } @lines;
+
+ # 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;
}
- # FIXME: Checking _PREVIOUS is breaking Pod::Parser encapsulation
- # but helps solve the extraneous extra blank line b/t verbatim blocks.
- # We could probably keep track ourselves if need be.
- # NOTE: This requires Pod::Parser 1.50.
- # This is another reason to switch to Pod::Simple.
- my $previous_was_verbatim =
- $parser->{_PREVIOUS} && $parser->{_PREVIOUS} eq 'verbatim';
+ return $paragraph;
+}
- if($previous_was_verbatim && $parser->_private->{Text}->[-1] =~ /[ \t]+$/){
- $paragraph = $parser->_unsave . "\n" . $paragraph;
+sub start_Para {
+ $_[0]->_new_stack;
+}
+
+sub end_Para {
+ my ($self) = @_;
+ my $text = $self->_pop_stack_text;
+
+ $text = $self->_escape_paragraph_markdown($text);
+
+ $self->_save_block($text);
+}
+
+
+## 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//;
}
+ }
+}
+sub _start_head {
+ my ($self) = @_;
+ $self->_check_search_header;
+ $self->_new_stack;
+}
+
+sub _end_head {
+ my ($self, $num) = @_;
+ my $h = '#' x $num;
+
+ 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));
+}
+
+## Lists ##
+
+# TODO: over_empty
+
+sub _start_list {
+ my ($self) = @_;
+ $self->_new_stack;
- $parser->_save($paragraph);
+ # Nest again b/c start_item will pop this to look for preceding content.
+ $self->_increase_indent;
+ $self->_new_stack;
}
-sub _escape_and_interpolate {
- my ($parser, $paragraph, $line_num) = @_;
+sub _end_list {
+ my ($self) = @_;
+ $self->_handle_between_item_content;
- # escape markdown characters in text sequences except for inline code
- $paragraph = join '', $parser->parse_text(
- { -expand_text => '_escape_non_code' },
- $paragraph, $line_num
- )->raw_text;
+ # Finish the list.
- # interpolate the paragraph for embedded sequences
- $paragraph = $parser->interpolate($paragraph, $line_num);
+ # All the child elements should be blocks,
+ # but don't end with a double newline.
+ my $text = $self->_chomp_all($self->_pop_stack_text);
- return $paragraph;
+ # FIXME:
+ $_[0]->_save_line($text . $/);
}
-sub _escape_non_code {
- my ($parser, $text, $ptree) = @_;
+sub _handle_between_item_content {
+ my ($self) = @_;
- if ($ptree->isa('Pod::InteriorSequence') && $ptree->cmd_name =~ /\A[CFL]\z/) {
- return $text;
+ # 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;
}
- return $parser->_escape($text);
-}
-
-# Handles normal blocks of POD.
-sub textblock {
- my ($parser, $paragraph, $line_num) = @_;
- my $data = $parser->_private;
- my $prelisthead;
-
- $paragraph = $parser->_escape_and_interpolate($paragraph, $line_num);
-
- # clean the empty lines
- $paragraph = $parser->_clean_text($paragraph);
-
- # 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) {
- # To compress into an item in order to avoid "\n\n" insertion.
- $prelisthead = $parser->_unsave();
- } else {
- $prelisthead = '';
- }
- $data->{searching} = 'listpara';
- } elsif ($data->{searching} eq 'listpara') {
- $data->{searching} = '';
+ # 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)
+ }
- # save the text
- $parser->_save($paragraph, $prelisthead);
-}
-
-# An interior sequence is an embedded command
-# within a block of text which appears as a command name - usually a single
-# uppercase character - followed immediately by a string of text which is
-# enclosed in angle brackets.
-sub interior_sequence {
- my ($self, $seq_command, $seq_argument, $pod_seq) = @_;
-
- # nested links are not allowed
- return sprintf '%s<%s>', $seq_command, $seq_argument
- if $seq_command eq 'L' && $self->_private->{InsideLink};
-
- my $i = 2;
- my %interiors = (
- 'I' => sub { return '_' . $_[$i] . '_' }, # italic
- 'B' => sub { return '__' . $_[$i] . '__' }, # bold
- 'C' => \&_wrap_code_span, # monospace
- 'F' => \&_wrap_code_span, # system path
- # non-breaking space
- 'S' => sub {
- (my $s = $_[$i]) =~ s/ / /g;
- return $s;
- },
- 'E' => sub {
- my $charname = $_[$i];
- return '<' if $charname eq 'lt';
- return '>' if $charname eq 'gt';
- return '|' if $charname eq 'verbar';
- return '/' if $charname eq 'sol';
-
- # convert legacy charnames to more modern ones (see perlpodspec)
- $charname =~ s/\A([lr])chevron\z/${1}aquo/;
-
- return "&#$1;" if $charname =~ /^0(x[0-9a-fA-Z]+)$/;
-
- $charname = oct($charname) if $charname =~ /^0\d+$/;
-
- return "&#$charname;" if $charname =~ /^\d+$/;
-
- return "&$charname;";
- },
- 'L' => \&_resolv_link,
- # TODO: create `a name=` if configured?
- 'X' => sub { '' },
- 'Z' => sub { '' },
- );
- if (exists $interiors{$seq_command}) {
- my $code = $interiors{$seq_command};
- return $code->($self, $seq_command, $seq_argument, $pod_seq);
- } else {
- return sprintf '%s<%s>', $seq_command, $seq_argument;
- }
+ $self->_decrease_indent;
+}
+
+sub _start_item {
+ my ($self) = @_;
+ $self->_handle_between_item_content;
+ $self->_new_stack;
}
-sub _resolv_link {
- my ($self, $cmd, $arg) = @_;
+sub _end_item {
+ my ($self, $marker) = @_;
+ $self->_save_line($self->_indent($marker . ' ' . $self->_pop_stack_text));
- local $self->_private->{InsideLink} = 1;
+ # Store any possible contents in a new stack (like a sub-document).
+ $self->_increase_indent;
+ $self->_new_stack;
+}
- my ($text, $inferred, $name, $section, $type) =
- # perlpodspec says formatting codes can occur in all parts of an L<>
- map { $_ && $self->interpolate($_, 1) }
- Pod::ParseLink::parselink($arg);
- my $url = '';
+sub start_over_bullet { $_[0]->_start_list }
+sub end_over_bullet { $_[0]->_end_list }
- if ($type eq 'url') {
- $url = $name;
- } elsif ($type eq 'man') {
- $url = $self->format_man_url($name);
- } else {
- $url = $self->format_perldoc_url($name, $section);
- }
+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('-')}
- # if we don't know how to handle the url just print the pod back out
- if (!$url) {
- return sprintf '%s<%s>', $cmd, $arg;
- }
- # TODO: put unescaped section into link title? [a](b "c")
- return sprintf '[%s](%s)', ($text || $inferred), $url;
+# 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() }
+
+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 start_X {
+ $_[0]->_new_stack;
+}
+
+sub end_X {
+ my ($self) = @_;
+ my $text = $self->_pop_stack_text;
+ # TODO: mangle $text?
+ # TODO: put <a name="$text"> if configured
}
# 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, undef, $arg) = @_;
+ my ($self, $arg) = @_;
my $longest = 0;
while( $arg =~ /([`]+)/g ){
my $len = length($1);
@@ -472,6 +736,8 @@ sub _wrap_code_span {
return $delim . $pad . $arg . $pad . $delim;
}
+## Link Formatting (TODO: Move this to another module) ##
+
sub format_man_url {
my ($self, $to) = @_;
@@ -613,4 +879,4 @@ sub format_fragment_sco { shift->format_fragment_pod_simple_html(@_); }
__END__
-#line 936
+#line 1265
@@ -6,7 +6,7 @@ use warnings;
use base 'Test::Builder::Module';
-our $VERSION = '0.41';
+our $VERSION = '0.42';
our $AUTHORITY = 'cpan:JJNAPIORK';
use Config::Any;
@@ -316,7 +316,7 @@ sub import {
}
return $resultset->search(@search);
}
- return $resultset;
+ return $resultset->search_rs;
}
};
} $schema_manager->schema->sources,
@@ -0,0 +1,9 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::DBIx::Class 'Person';
+use Scalar::Util qw(refaddr);
+
+isnt(refaddr(Person()), refaddr(Person()), 'Got two different resultsets');
+done_testing();