Test-DatabaseRow-2.03/000755 000765 000765 00000000000 11715142631 014510 5ustar00markmark000000 000000 Test-DatabaseRow-2.03/CHANGES000644 000765 000765 00000006245 11715142445 015515 0ustar00markmark000000 000000 2.03 Wrap qw() with () in foreach loops (thus avoiding deprecation warnings on 5.14. (Thanks to Gabor Szabo for pull request) Fix tests to delete sqlite test database on Windows (Thanks to Gabor Szabo for pull request) 2.02 Changed "label" to "diagnostic" (but kept backwards compatible accepting of old object.) Fix bug where an invalid comparison operator would cause test failure rather than throwing an exception (bad input should create exceptions, not fail tests) Added better error messages when passing invalid tests in. Improved commenting and flow control for better maintainability. 2.01 Add tests that use DBD::SQLite to test a real database Fix the bugs with the DBI interface (thanks to ilmari for pointing these out) 2.00 Added Test::DatabaseRow::Object and Test::DatabaseRow::Result. Rewrote Test::DatabaseRow to use these classes to do everything Added "all_rows_ok" function and ability to check all database rows returned improved test coverage. Fix for bug where tests => [ "time" => "2011-11-11 11:32:26" ] would have been interpreted as tests => { '==' => { "time" => "2011-11-11 11:32:26" } } not tests => { 'eq' => { "time" => "2011-11-11 11:32:26" } } 1.05 fix for 5.13.6+ new regualar expression stringification breaking our own test suite Moved to Module::Install instead of Module::Build. Add standard Kwalitee tests and make them pass. Fixed the eval statements to cope with resetting of $@ in a DESTROY block (an issue in Perl 5.12 and below) Addressed a bug that could leave fatal errors enabled on on the passed database handle after an exception had been raised Addresses a bug where the arrayref passed as the "sql" argument would be altered Improved the documentation Refactored a lot of code; Switch bracing convention. Removed the sub package. Disabled "use warnings" making this compatible with 5.004 (this release never made it to the CPAN) 1.04 added utf8 hack to allow data from the database to be marked as utf8 before it's compared to anything 1.03 added the ability to get at the results after you've run row_ok 1.02 Added Build.PL to the MANIFEST (oops) Patches from Andy Lester to mean: Fixed docs on not_row_ok. results, max_results and min_results now show the actual incorrect values, instead of hardcoded leftovers. 1.01 added negative assertions, due to request from pudge and Andy reminding me about it. 1.00 finally fixed warnings problem with Leon Brocard's help added bind parameters with arrayref being passsed to sql added documentation of how to use with SQL::Abstract 0.06 allowed test without 'tests' to just check for existance of rows 0.05 added Test::Warn based tests 0.04 verbose mode added WHERE 1 = 1 removed due to Richard Clamp's nagging 0.03 NULL behavior added Proper error messages for missing columns check die on problem with the SQL 0.02 Documentation typos patched by Kate L Pugh 0.01 Inital Release Test-DatabaseRow-2.03/inc/000755 000765 000765 00000000000 11715142631 015261 5ustar00markmark000000 000000 Test-DatabaseRow-2.03/lib/000755 000765 000765 00000000000 11715142631 015256 5ustar00markmark000000 000000 Test-DatabaseRow-2.03/Makefile.PL000644 000765 000765 00000001130 11656751223 016464 0ustar00markmark000000 000000 use inc::Module::Install; name 'Test-DatabaseRow'; all_from 'lib/Test/DatabaseRow.pm'; # any version of DBI will do, I guess...? requires 'DBI' => 0; # I don;t know what version of Scalar::Util first # shipped with a working "blessed" function # but at the time of writing this was the # earliest version still on the CPAN and it did # support blessed. requires 'Scalar::Util' => 1.21; # T::B::T before 0.09 breaks with modern perls build_requires 'Test::Builder::Tester' => 0.09; license 'perl'; githubmeta; author_tests('xt'); WriteAll; Test-DatabaseRow-2.03/MANIFEST000644 000765 000765 00000001202 11657204655 015646 0ustar00markmark000000 000000 CHANGES inc/Module/Install.pm inc/Module/Install/AuthorTests.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/GithubMeta.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Test/DatabaseRow.pm lib/Test/DatabaseRow/Object.pm lib/Test/DatabaseRow/Result.pm Makefile.PL MANIFEST This list of files META.yml t/01basic.t t/01tests.t t/02throws.t t/03tests.t t/05warn.t t/06multiple.t t/07results.t t/08utf8.t t/09has.t t/10result.t t/11th.t xt/001pod.t xt/002podcoverage.t xt/003perlcritic.t xt/anyperlperlcriticrc Test-DatabaseRow-2.03/META.yml000644 000765 000765 00000001321 11715142567 015766 0ustar00markmark000000 000000 --- abstract: 'simple database tests' author: - 'Written by Mark Fowler B' build_requires: ExtUtils::MakeMaker: 6.42 Test::Builder::Tester: 0.09 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 1.00' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Test-DatabaseRow no_index: directory: - inc - t - xt requires: DBI: 0 Scalar::Util: 1.21 perl: 5.6.0 resources: homepage: http://github.com/2shortplanks/Test-DatabaseRow/tree license: http://dev.perl.org/licenses/ repository: git://github.com/2shortplanks/Test-DatabaseRow.git version: 2.03 Test-DatabaseRow-2.03/t/000755 000765 000765 00000000000 11715142631 014753 5ustar00markmark000000 000000 Test-DatabaseRow-2.03/xt/000755 000765 000765 00000000000 11715142631 015143 5ustar00markmark000000 000000 Test-DatabaseRow-2.03/xt/001pod.t000644 000765 000765 00000000336 11656704265 016350 0ustar00markmark000000 000000 #!perl ############## STANDARD Test::Pod TEST - DO NOT EDIT #################### use strict; use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); Test-DatabaseRow-2.03/xt/002podcoverage.t000644 000765 000765 00000000535 11656704305 020061 0ustar00markmark000000 000000 #!perl ############ STANDARD Pod::Coverage TEST - DO NOT EDIT ################## use Test::More; use strict; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::CountParents', also_private => [ qr/\A has_ /x], }); Test-DatabaseRow-2.03/xt/003perlcritic.t000644 000765 000765 00000000646 11656704343 017731 0ustar00markmark000000 000000 #!perl ############ STANDARD Perl::Critic TEST - DO NOT EDIT ################## use strict; use File::Spec::Functions; use FindBin; use Test::More; unless (require Test::Perl::Critic) { Test::More::plan( skip_all => "Test::Perl::Critic required for complaining compliance" ); } Test::Perl::Critic->import( -profile => catfile( $FindBin::Bin, "anyperlperlcriticrc" ) ); Test::Perl::Critic::all_critic_ok(); Test-DatabaseRow-2.03/xt/anyperlperlcriticrc000644 000765 000765 00000037703 11656760641 021173 0ustar00markmark000000 000000 ################################################################################### # MARK FOWLER's PERL CRITIC FILE ################################################################################### ################################################################################### # GLOBAL SETTINGS severity=3 verbose=8 ################################################################################### # PERL::CRITIC BUILTIN RULES [BuiltinFunctions::ProhibitBooleanGrep] # DONT'T ENABLE THIS # While there's better ways to write this, it's not easy to write when you can't # rely on List::Util et al being installed (i.e. when I'm targetting older perls) severity=1 [BuiltinFunctions::ProhibitComplexMappings] # DON'T ENABLE THIS # I don't want to prohibit writing multi line spanning maps. # While I think that *other* *people* shouldn't do this, I think that when I do it # it's fine. Hyprocritical? You betcha. severity=1 [BuiltinFunctions::ProhibitLvalueSubstr] # Force substr($x,$start,$len,$replacement) rather thatn substr($x,$start,$len) = $replacement # YES! severity=5 [BuiltinFunctions::ProhibitReverseSortBlock] # Force "reverse sort { $a cmp $b } ..." not "sort { $b cmp $a } ..." # YES! severity=5 [BuiltinFunctions::ProhibitSleepViaSelect] # prohibit writing select undef,undef,undef,0.25 to sleep # The only reason not to do this is the belief that it's not widely understood. # I think that it *is* widely understood. And the alternatives require using # a module that doesn't ship with older Perls. Therefore, don't do it. severity=1 [BuiltinFunctions::ProhibitStringyEval] # DON'T ENABLE THIS # This is a biggy. We probably shouldn't allow string eval at all, but the truth is # I know what I'm doing enough that if I used it, I meant it. The reasons for # disallowing it is purely to stop you accidentally using it when you meant eval { ... } # and since I don't do that, I'm going to leave this off. severity=1 [BuiltinFunctions::ProhibitStringySplit] # make it impossible to write split(":",$string) # YES! make it so you have to write split(/:/,$string) as that's what split(":",$string) does severity=5 [BuiltinFunctions::ProhibitUniversalCan] # Make it impossbile to write use UNIVERSAL::can($foo,...)? # YES! It breaks mocking. Use blessed($foo) && $foo->can(...) severity=5 [BuiltinFunctions::ProhibitUniversalIsa] # Make it impossbile to write use UNIVERSAL::isa($foo,...)? # YES! It breaks mocking. Use blessed($foo) && $foo->isa(...) severity=5 [BuiltinFunctions::ProhibitVoidGrep] # Stop using grep as a loop? # YES! use a "for" severity=5 [BuiltinFunctions::ProhibitVoidMap] # Stop using map as a loop? # YES! use a "for" severity=5 [BuiltinFunctions::RequireBlockGrep] # Force you to write grep { /foo/ } @_ not grep /foo/, @_ # YES! Everyone always gets the latter form wrong severity=5 [BuiltinFunctions::RequireBlockMap] # Force you to write map { foo($_) } @_ not map foo($_), @_ # YES! Everyone always gets the latter form wrong severity=5 [BuiltinFunctions::RequireGlobFunction] # Stop writing <*.pl> to get all files called *.pl? # YES! use glob("*.pl") instead. Or File::Find::Rule! severity=5 [BuiltinFunctions::RequireSimpleSortBlock] # Don't allow complex sort blocks? # YES! My sort blocks should be fairly straight forward severity=1 [ClassHierarchies::ProhibitAutoloading] # Stop writing AUTOLOADING code? # NO! It's a bad idea, but it's not something I'd do by accident severity=2 [ClassHierarchies::ProhibitExplicitISA] # Don't write @ISA=() write "use base" # NO! It stops our code being backwards compatible severity=2 [ClassHierarchies::ProhibitOneArgBless] # Don't let anyone write "return bless {};" # YES! That breaks inheritence severity=5 [CodeLayout::ProhibitHardTabs] # Don't allow tabs in your sourcecode? # YES! TABS are the work of the devil! severity=5 [CodeLayout::ProhibitParensWithBuiltins] # NO! Sometimes I need them for precidence severity=1 [CodeLayout::ProhibitQuotedWordLists] # Force qw(foo bar baz) rather than ("foo","bar","baz") # NO! sometimes I need this for lists that often contain non-ascii # parts but simply don't happen to in this particular example severity=1 [CodeLayout::ProhibitTrailingWhitespace] # ...probably a good idea severity=3 [CodeLayout::RequireConsistentNewlines] # don't allow people to mix \n and \r\n # YES! subversion should protect us from this so turn it on severity=5 [CodeLayout::RequireTrailingCommas] # force extra trailing commas in multiline lists # NO! This policy is too dumb to actually enforce that properly severity=1 [ControlStructures::ProhibitCStyleForLoops] # NO! If I use them, I need them. severity=1 [ControlStructures::ProhibitCascadingIfElse] # Force using a switch module instead? # NO! All the swtich modules suck. When we've all got 5.10 # with the inbuilt switch, we can start using this, but not until severity=1 [ControlStructures::ProhibitDeepNests] # Don't allow deep nests of code # ...probably a good idea, if annoying severity=3 [ControlStructures::ProhibitMutatingListFunctions] # Don't allow maps / grep to mutate the original elements # YES! people should use "for" for that severity=5 [ControlStructures::ProhibitPostfixControls] # Don't allow $foo if $bar; # NO! This makes my code more readable severity=1 [ControlStructures::ProhibitUnlessBlocks] # NO! Unless blocks increase readability severity=1 [ControlStructures::ProhibitUnreachableCode] # Checks for basic unreachable code (doesn't check for # if { return ... } else { return ...} unreachable) # YES! Writing stupid code should not be allowed severity=5 [ControlStructures::ProhibitUntilBlocks] # Stop writing until() { ... } # NO! this increases readability severity=1 [Documentation::RequirePodAtEnd] # Require all the pod at the end # NO! It should be throughout the code! severity=1 [Documentation::RequirePodSections] # Require the pod throughout your code? # YES! It should be throughout the code! lib_sections = NAME | SYNOPSIS | DESCRIPTION | AUTHOR | BUGS | SEE ALSO script_sections = NAME | SYNOPSIS | DESCRIPTION | AUTHOR | BUGS | SEE ALSO severity=5 [ErrorHandling::RequireCarping] # make us use carp and croak not warn or die # ...probably a good idea severity=3 [InputOutput::ProhibitBacktickOperators] # yes, we should be using open instead severity=4 [InputOutput::ProhibitBarewordFileHandles] # Use bare filehandles In my source code? # NO! That's just insane! severity=5 [InputOutput::ProhibitInteractiveTest] # This sounds like a bad idea. Let's deny it severity=5 [InputOutput::ProhibitJoinedReadline] # yeah, let's not be lazy and write this the proper way severity=4 [InputOutput::ProhibitOneArgSelect] # one arg selects are fine in my book severity=1 [InputOutput::ProhibitReadlineInForLoop] # this is just lazy. Don't allow it severity=5 [InputOutput::ProhibitTwoArgOpen] # two arg opens lead to security bugs. Get rid of them! severity=5 [InputOutput::RequireBracedFileHandleWithPrint] # Yeah, you should be encouraged to do this severity=3 [InputOutput::RequireCheckedClose] # you should *always* check closes, but I'm not too fussy severity=2 [InputOutput::RequireCheckedOpen] # you should *always* check opens severity=5 [Miscellanea::ProhibitFormats] # Formats suck severity=5 [Miscellanea::ProhibitTies] # Stop ties? NO! I LIKE TIES severity=1 [Miscellanea::RequireRcsKeywords] # require $Revision: 1890$? # NO! I know how to use the svn command thankyou severity=1 [Modules::ProhibitAutomaticExportation] # Prevent using @EXPORT and force @EXPORT_OK et al instead # NO! If I'm exporting, I mean it darnit severity=1 [Modules::ProhibitEvilModules] # Don't allow use of Acme modules modules=/Acme::/ [Modules::ProhibitExcessMainComplexity] # Don't allow me to write complex main code severity=3 [Modules::ProhibitMultiplePackages] # Don't let me write multiple packages # NO! I use this to declare error classes severity=1 [Modules::RequireBarewordIncludes] # Stop people writing "use 'foo'" with the quotes # YES! That's just crazy severity=1 [Modules::RequireEndWithOne] # End our code with 1; rather than "Club Sandwitch" # ...boring, but probably a good idea severity=3 [Modules::RequireExplicitPackage] # make sure that people start modules with "package ..." # YES...stops subtle bugs severity=5 [Modules::RequireFilenameMatchesPackage] # catch the annoying case where you have one filename # but accidentally put in another package name? # YES! There's no reason not to do this severity=5 [Modules::RequireVersionVar] # make us have a $VERSION in our modules? # ...probably a good idea severity=4 [NamingConventions::ProhibitAmbiguousNames] # varnames we're not allowed to use because theu're ambigious severity=5 forbid = last set left right no abstract contract record second close [NamingConventions::ProhibitMixedCaseSubs] # Don't allow camelcasing our subs? YES severity=5 [NamingConventions::ProhibitMixedCaseVars] # Don't allow camelcasing our vars? YES severity=5 [References::ProhibitDoubleSigils] # force people to write ${ @foo } rather than $@foo # YES! stops things being so darn confusing severity=5 [RegularExpressions::ProhibitCaptureWithoutTest] # force peopel to test if re captures produced output # YES! Don't forget this severity=5 [RegularExpressions::RequireExtendedFormatting] # force people to use /.../x # ...seems like a good idea severity=4 [RegularExpressions::RequireLineBoundaryMatching] # force people to use /.../m # NO! I'm a perl programmer and find it confusing to use \A and \Z severity=1 [Subroutines::ProhibitAmpersandSigils] # force people to write "foo()" not "&foo()" # YES! severity=5 [Subroutines::ProhibitBuiltinHomonyms] # Prevent declaring "sub open {...}" and it's ilk # NO! because I might create an object like this and this module # is too dumb to realise that's what I'm doing severity=1 [Subroutines::ProhibitExcessComplexity] # Seems like a good idea severity=2 [Subroutines::ProhibitExplicitReturnUndef] # NO, if I say this I mean this severity=2 [Subroutines::ProhibitManyArgs] # disallow writing subroutines that take more than five args # ...probably a good idea severity=1 max_arguments=5 [Subroutines::ProhibitNestedSubs] # prevent people from writing non anonymous subs in subs # YES! This is totally unreadable severity=1 [Subroutines::ProhibitSubroutinePrototypes] # NO! I use this to create DSL severity=1 [Subroutines::ProtectPrivateSubs] # catch people doing Foo::Bar::_baz severity=5 allow=Encode::_utf8_on [Subroutines::RequireArgUnpacking] # NO, often I really mean it severity=1 [Subroutines::RequireFinalReturn] # make sure all subroutines exit with a return (or other) # ...this seems like a good idea severity=4 [TestingAndDebugging::ProhibitNoStrict] # make sure you can't turn strict off # allow overriding certain things though severity=5 allow = vars subs refs [TestingAndDebugging::ProhibitNoWarnings] # make sure you can't turn warnings off # allow overriding certain things though severity=5 allow = uninitialized once [TestingAndDebugging::ProhibitProlongedStrictureOverride] # make sure no strict isn't turned off for zillions of lines of code severity=5 statements = 10 # more than the default, but not enough for the entire program [TestingAndDebugging::RequireTestLabels] # ensure that out tests have labels # YES! I tend to leave these off, then get confused severity=5 [TestingAndDebugging::RequireUseStrict] # force use strict to be turned on severity=5 [TestingAndDebugging::RequireUseWarnings] # Yes, but I also want code that runs on 5.005 and so, so # low severity severity=2 [ValuesAndExpressions::ProhibitCommaSeparatedStatements] # catch where "," rather than ";" is used as a statement seperator (even by accident) # YES severity=5 [ValuesAndExpressions::ProhibitConstantPragma] # make people write $FOO = 2 rather than "use constant FOO => 2" # YES, as constants keep biting you in hashes severity=5 [ValuesAndExpressions::ProhibitEmptyQuotes] # make people write q{ } not ' ' for whitespace # NO, I find this harder to read as my brain thinks empty q{ } is a block severity=1 [ValuesAndExpressions::ProhibitEscapedCharacters] # make people write \N{DELETE} rather than \x7f # NO, since after all these years it's harder for me to read the names than the char codes severity=2 [ValuesAndExpressions::ProhibitImplicitNewlines] # don't let people put newlines in the middle of scripts! severity=5 [ValuesAndExpressions::ProhibitInterpolationOfLiterals] # disallow writing "foo" instead of 'foo' for literals # NO! I write things like "It's a bad idea" all the time! severity=1 [ValuesAndExpressions::ProhibitLeadingZeros] # disallow 0000123 # YES! I can never remember that this is actualy octal severity=5 [ValuesAndExpressions::ProhibitLongChainsOfMethodCalls] # disallow $a->b->c->d->e # NO! Good OO is often written like this severity=1 [ValuesAndExpressions::ProhibitMismatchedOperators] # disallow "if ($a == '123')" and "if ($a eq 123)" # YES! It's a warning anyway severity=5 [ValuesAndExpressions::ProhibitMixedBooleanOperators] # disallow "next if not ($a || $b)" (low and hight presidence booleans) # YES! Write readable code darnit severity=5 [ValuesAndExpressions::ProhibitNoisyQuotes] # NO, this makes you code hard to read severity=1 [ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters] # Disallow m"foo" and it's ilk # YES, this is just wrong severity=5 [ValuesAndExpressions::ProhibitVersionStrings] # disallow $foo = v1.2.3.4 # YES, this is just wrong severity=5 [ValuesAndExpressions::RequireInterpolationOfMetachars] # complain about '\t' et al (not '\\t' or "\t") # YES, since this can bite you if you're not careful severity=5 [ValuesAndExpressions::RequireNumberSeparators] # require that big numbers be written like 100_000 not 100000 severity=5 min_value = 10000 # the default, but hardcoded here [ValuesAndExpressions::RequireQuotedHeredocTerminator] # For heredoc terminators to be quoted like <<'HEREDOC' or <<"HEREDOC" # YES! Because it makes you clear if interpolation is happening or not severity=5 [ValuesAndExpressions::RequireUpperCaseHeredocTerminator] # force heredoc terminators to be UPPER_CASE # YES! It makes them readable severity=5 [Variables::ProhibitConditionalDeclarations] # stop people writing "my $foo = $bar if $baz" # YES! This is very confusing code severity=5 [Variables::ProhibitLocalVars] # While I agree with the ideas behind this, being not # able to write 'local $/' is confusing to me (I hate English.pm) severity=1 [Variables::ProhibitMatchVars] # Don't let people use $`, $& and $' # YES! use capturing, or in 5.10 /p and ${^PREMATCH} et al severity=5 [Variables::ProhibitPackageVars] # Not for this module. Maybe it was a good idea, but in this # case, back in 2003 we made the interface use package # vars, so there's little I can do here... severity=1 add_packages=Test::Builder Carp DBI [Variables::ProhibitPerl4PackageNames] # Don't allow people to write Foo'Bar'Baz not Foo::Bar::Baz # YES! This is just plain silly, and mucks up my editor severity=4 [Variables::ProhibitPunctuationVars] # Disallow $/ and force people to use English # NO! $/ makes more sense to me than the english name severity=1 [Variables::ProtectPrivateVars] # don't write $Foo::bar::_goo from another package # YES! infact, we shouldn't have those vars at all severity=5 [Variables::RequireInitializationForLocalVars] # Require people initilize local vars? # YES! Forgetting so is a bad mistake severity=5 [Variables::RequireLexicalLoopIterators] # Force people to use "for my $thingy (...)" with the my # YES! this is a common mistake! severity=5 [Variables::RequireLocalizedPunctuationVars] # Stop people changing $/ et all without localising them? # YES! Say _no_ to sideeffects severity=5 [Variables::RequireNegativeIndices] # make people write $foo[-1] rather than $foo[ $#foo - 1 ] ? # YES! I like my code readable severity=5 [Subroutines::ProhibitUnusedPrivateSubroutines] # NO, since I'm emulating moose I need to create private # method calls that are called dynamically severity=1 ################################################################################### # PERL::CRITIC::MORE RULES #[CodeLayout::RequireASCII] # I hate unicode in source code. Use escapes damnit #severity=5 Test-DatabaseRow-2.03/t/01basic.t000644 000765 000765 00000010051 11656702676 016376 0ustar00markmark000000 000000 #!/usr/bin/perl ######################################################################## # this test checks to see if the handling of sql_and_bind works, and if # sql_and_bind is automatically created from table and where if needed ######################################################################## use strict; use warnings; use Test::More tests => 12; ######################################################################## # load the module / setup ######################################################################## BEGIN { use_ok "Test::DatabaseRow::Object" } # create a fake dbh connection. The quote function in this class # just marks the text up with "qtd" so we can see what would # have been really quoted if it was a real dbh connection my $dbh = FakeDBI->new(); ######################################################################## # coercian ######################################################################## { my $tbr = Test::DatabaseRow::Object->new( dbh => $dbh, sql_and_bind => q{SELECT * FROM foo WHERE fooid = 123}, ); is($tbr->sql_and_bind->[0], q{SELECT * FROM foo WHERE fooid = 123}, "simple test" ); } ######################################################################## { my $tbr = Test::DatabaseRow::Object->new( dbh => $dbh, sql_and_bind => [ q{SELECT * FROM foo WHERE fooid = 123} ], ); is_deeply($tbr->sql_and_bind, [ q{SELECT * FROM foo WHERE fooid = 123} ], "simple test sql arrayref no bind" ); } ######################################################################## { my $array = [ q{SELECT * FROM foo WHERE fooid = ? AND bar = ?}, 123, 456 ]; my $tbr = Test::DatabaseRow::Object->new( dbh => $dbh, sql_and_bind => $array, ); is_deeply( $array, [ q{SELECT * FROM foo WHERE fooid = ? AND bar = ?}, 123, 456 ], "array passed in unaltered", ); is_deeply( $tbr->sql_and_bind, [ q{SELECT * FROM foo WHERE fooid = ? AND bar = ?}, 123, 456 ], "simple test sql arrayref with bind" ); } ######################################################################## # from where and table ######################################################################## { my $where = { '=' => { fooid => 123, bar => "abc" } }; my $tdr = Test::DatabaseRow::Object->new( dbh => $dbh, table => "foo", where => $where ); is_deeply( $where, { '=' => { fooid => 123, bar => "abc" } }, "where datastructure unaltered" ); is_deeply( $tdr->sql_and_bind, [ q{SELECT * FROM foo WHERE bar = qtd AND fooid = qtd<123>} ], "simple equals test" ); } ######################################################################## { my $where = [ fooid => 123, bar => "abc" ]; my $tbr = Test::DatabaseRow::Object->new( dbh => $dbh, table => "foo", where => $where ); is_deeply( $where, [ fooid => 123, bar => "abc" ], "where datastructure unaltered" ); is_deeply( $tbr->sql_and_bind, [ q{SELECT * FROM foo WHERE bar = qtd AND fooid = qtd<123>} ], "simple equals test with shortcut" ); } ######################################################################## # nulls ######################################################################## is_deeply( Test::DatabaseRow::Object->new( dbh => $dbh, table => "foo", where => [ fooid => undef ] )->sql_and_bind, [q{SELECT * FROM foo WHERE fooid IS NULL}], "auto null test" ); is_deeply( Test::DatabaseRow::Object->new( dbh => $dbh, table => "foo", where => { "=" => { fooid => undef } } )->sql_and_bind, [q{SELECT * FROM foo WHERE fooid IS NULL}], "auto null test2" ); is_deeply( Test::DatabaseRow::Object->new( dbh => $dbh, table => "foo", where => { "IS NOT" => { fooid => undef } } )->sql_and_bind, [q{SELECT * FROM foo WHERE fooid IS NOT NULL}], "auto null test3" ); ######################################################################## # fake database package package FakeDBI; sub new { return bless {}, shift }; sub quote { return "qtd<$_[1]>" }; Test-DatabaseRow-2.03/t/01tests.t000644 000765 000765 00000001465 11656702621 016456 0ustar00markmark000000 000000 #!/usr/bin/perl ######################################################################## # this test checks that what we pass to tests is handled correctly ######################################################################## use strict; use warnings; use Test::More tests => 5; BEGIN { use_ok "Test::DatabaseRow::Object" } ######################################################################## { my $tdr = Test::DatabaseRow::Object->new( tests => [ numbers => 123, string => "foo", regex => qr/foo/ ] ); my $hashref = $tdr->tests; is(ref($hashref),"HASH", "tests a hashref"); is($hashref->{'=~'}{regex}, qr/foo/, "regex rearanged"); is($hashref->{'=='}{numbers}, 123, "number rearagned"); is($hashref->{'eq'}{string}, "foo", "string rearagned"); } Test-DatabaseRow-2.03/t/02throws.t000644 000765 000765 00000010550 11667635670 016651 0ustar00markmark000000 000000 #!/usr/bin/perl -w use strict; # check if we can run Test::Exception BEGIN { eval { require Test::Exception; Test::Exception->import }; if ($@) { print "1..0 # Skipped: no Test::Exception\n"; exit; } } use Test::More tests => 17; use Test::Exception; use Test::DatabaseRow; # check we get the correct error message throws_ok { row_ok } qr/Needed fetch results but no 'dbh' defined/, "no dbh"; # define a new default database $Test::DatabaseRow::dbh = FakeDBI->new; # no table test throws_ok { row_ok } qr/Needed to build SQL but no 'table' defined/, "no table"; # no where test throws_ok { row_ok( table => "foo" ) } qr/Needed to build SQL but no 'where' defined/, "no where"; # bad where tests throws_ok { row_ok( table => "foo", where => \"wibble" ) } qr/Can't understand the argument passed in 'where'/, "bad where"; throws_ok { row_ok( table => "foo", where => { foo => [ this => "wrong" ] } ) } qr/Can't understand the argument passed in 'where'/, "bad where 2"; # no tests - this is okay now #throws_ok { row_ok( table => "foo", # where => [ fooid => 123 ] ) } # qr/No 'tests' passed as an arguement/, "no tests"; # odd tests throws_ok { row_ok( table => "foo", where => [ fooid => 123 ] , tests => \"fish" ) } qr/Can't understand the argument passed in 'tests': not a hashref or arrayref/, "bad tests"; # odd tests throws_ok { row_ok( table => "foo", where => [ fooid => 123 ] , tests => { foo => [ bar => "baz" ] } ); } qr/Can't understand the argument passed in 'tests': key 'foo' didn't contain a hashref/, "bad tests 2"; throws_ok { row_ok( table => "foo", where => [ fooid => 123 ] , tests => [ notpresent => 1 ] ) } qr/No column 'notpresent' returned from table 'foo'/, "no col from build"; throws_ok { row_ok( sql => "some sql", tests => [ notpresent => 1 ] ) } qr/No column 'notpresent' returned from sql/, "no col from sql"; dies_ok { row_ok( dbh => FakeDBI->new(fallover => 1, "hello" => "there"), sql => "any old gumph", tests => [ fooid => 1 ]) } "handles problems with sql"; throws_ok { row_ok( db_results => [ { foo => "bar" } ], tests => { invalidop => { foo => 'bar' } } ) } qr/Invalid operator test 'invalidop': \S+/, "invalid operator"; ######################################################################## # bad SQL throws_ok { row_ok( sql => \[] ) } qr/Can't understand the sql/; ######################################################################## # bad storage throws_ok { row_ok( sql => "some sql", store_rows => {}) } qr/Must pass an arrayref in 'store_rows'/, "no col from sql"; throws_ok { row_ok( sql => "some sql", store_row => \"foo") } qr/Invalid argument passed in 'store_row'/, "no col from sql"; ######################################################################## # Test::DatabaseRow::Object { my $tdr = Test::DatabaseRow::Object->new(where => [ foo => "bar" ], table => "buzz" ); throws_ok { $tdr->sql_and_bind } qr/Needed to quote SQL during SQL building but no 'dbh' defined/, "quote but no dbh" } { throws_ok { my $tdr = Test::DatabaseRow::Object->new( tests => [qw( a b c)] ); } qr/Can't understand the passed test arguments/, "odd tests" } ######################################################################## # Test::DatabaseRow::Result throws_ok { Test::DatabaseRow::Result->new( diag => {} ) } qr/Invalid argument to diag/, "diag invalid"; ######################################################################## # fake database package package FakeDBI; use Data::Dumper; sub new { my $class = shift; return bless { @_ }, $class } sub quote { return "qtd<$_[1]>" }; sub prepare { my $this = shift; # die if we need to if ($this->fallover) { die "Khaaaaaaaaaaaaan!" } return FakeSTH->new($this); } sub nomatch { return $_[0]->{nomatch} } sub fallover { return $_[0]->{fallover} } package FakeSTH; sub new { return bless { parent => $_[1] }, $_[0] }; sub execute { return 1 }; sub fetchrow_hashref { my $this = shift; my $parent = $this->{parent}; # return undef after the first call) if ($this->{called}) { return } else { $this->{called} = 1 } return ($parent->nomatch) ? undef : { fooid => 123, name => "fred" } } Test-DatabaseRow-2.03/t/03tests.t000644 000765 000765 00000016721 11656762451 016470 0ustar00markmark000000 000000 #!/usr/bin/perl -w use strict; use Test::More tests => 17; use Test::DatabaseRow; use Test::Builder::Tester; $Test::DatabaseRow::dbh = FakeDBI->new(); # cope with the fact that regular expressions changed # stringification syntax in 5.13.6 my $DEFAULT = $] >= 5.01306 ? '^' : '-xism'; test_out("ok 1 - matches"); row_ok(table => "dummy", where => [ dummy => "dummy" ], label => "matches"); test_test("no tests"); test_out("ok 1 - matches"); row_ok(table => "dummy", where => [ dummy => "dummy" ], tests => [ fooid => 123, name => "fred", name => qr/re/ ], description => "matches"); test_test("matching with shortcut"); test_out("ok 1 - matches"); row_ok(table => "dummy", where => [ dummy => "dummy" ], tests => { "==" => { fooid => 123 }, "eq" => { name => "fred" }, "=~" => { name => qr/re/ },}, label => "matches"); test_test("matching without shortcut"); test_out("ok 1 - simple db test"); row_ok(table => "dummy", where => [ dummy => "dummy" ], tests => { "==" => { fooid => 123 }, "eq" => { name => "fred" }, "=~" => { name => qr/re/ },},); test_test("default test name"); test_out("not ok 1 - matches"); test_fail(+4); test_diag("While checking column 'fooid' on 1st row"); test_diag(" got: 123"); test_diag(" expected: 124"); row_ok(table => "dummy", where => [ dummy => "dummy" ], tests => [ fooid => 124, name => "fred", name => qr/re/ ], label => "matches"); test_test("failing =="); test_out("not ok 1 - matches"); test_fail(+7); test_diag("While checking column 'fooid' on 1st row"); test_diag(" got: 123"); test_diag(" expected: 124"); test_diag("The SQL executed was:"); test_diag(" SELECT * FROM dummy WHERE dummy = qtd"); test_diag("on database 'bob'"); row_ok(table => "dummy", where => [ dummy => "dummy" ], tests => [ fooid => 124, name => "fred", name => qr/re/ ], label => "matches", verbose => 1); test_test("failing == verbose"); test_out("not ok 1 - matches"); test_fail(+9); test_diag("While checking column 'fooid' on 1st row"); test_diag(" got: 123"); test_diag(" expected: 124"); test_diag("The SQL executed was:"); test_diag(" SELECT * FROM dummy WHERE dummy = ?"); test_diag("The bound parameters were:"); test_diag(" 'dummy'"); test_diag("on database 'bob'"); row_ok(sql => [ "SELECT * FROM dummy WHERE dummy = ?", "dummy"], tests => [ fooid => 124, name => "fred", name => qr/re/ ], label => "matches", verbose => 1); test_test("failing == verbose bind"); test_out("not ok 1 - matches"); test_fail(+4); test_diag("While checking column 'name' on 1st row"); test_diag(qq{ got: 'fred'}); test_diag(qq{ expected: 'frea'}); row_ok(table => "dummy", where => [ dummy => "dummy" ], tests => [ fooid => 123, name => "frea", name => qr/re/ ], label => "matches"); test_test("failing eq"); test_out("not ok 1 - matches"); test_fail(+7); test_diag("While checking column 'name' on 1st row"); test_diag(qq{ got: 'fred'}); test_diag(qq{ expected: 'frea'}); test_diag("The SQL executed was:"); test_diag(" SELECT * FROM dummy WHERE dummy = qtd"); test_diag("on database 'bob'"); row_ok(table => "dummy", where => [ dummy => "dummy" ], tests => [ fooid => 123, name => "frea", name => qr/re/ ], label => "matches", verbose => 1); test_test("failing eq verbose"); test_out("not ok 1 - matches"); test_fail(+5); test_diag("While checking column 'name' on 1st row"); test_diag(qq{ 'fred'}); test_diag(qq{ =~}); test_diag(qq{ '(?$DEFAULT:rd)'}); row_ok(table => "dummy", where => [ dummy => "dummy" ], tests => [ fooid => 123, name => "fred", name => qr/rd/ ], label => "matches"); test_test("failing =~"); test_out("not ok 1 - matches"); test_fail(+8); test_diag("While checking column 'name' on 1st row"); test_diag(qq{ 'fred'}); test_diag(qq{ =~}); test_diag(qq{ '(?$DEFAULT:rd)'}); test_diag("The SQL executed was:"); test_diag(" SELECT * FROM dummy WHERE dummy = qtd"); test_diag("on database 'bob'"); row_ok(table => "dummy", where => [ dummy => "dummy" ], tests => [ fooid => 123, name => "fred", name => qr/rd/ ], label => "matches", verbose => 1); test_test("failing =~ verbose"); test_out("not ok 1 - matches"); test_fail(+5); test_diag("While checking column 'fooid' on 1st row"); test_diag(qq{ '123'}); test_diag(qq{ <}); test_diag(qq{ '12'}); row_ok(table => "dummy", where => [ dummy => "dummy" ], tests => { "<", { fooid => 12 }}, label => "matches"); test_test("failing <"); test_out("not ok 1 - matches"); test_fail(+5+3); test_diag("While checking column 'fooid' on 1st row"); test_diag(qq{ '123'}); test_diag(qq{ <}); test_diag(qq{ '12'}); test_diag("The SQL executed was:"); test_diag(" SELECT * FROM dummy WHERE dummy = qtd"); test_diag("on database 'bob'"); row_ok(table => "dummy", where => [ dummy => "dummy" ], tests => { "<", { fooid => 12 }}, label => "matches", verbose => 1); test_test("failing < verbose"); test_out("not ok 1 - matches"); test_fail(+2); test_diag("No matching row returned"); row_ok(dbh => FakeDBI->new(nomatch => 1), sql => "dummy", tests => [ "fooid" => 1 ], label => "matches"); test_test("no returned data"); test_out("not ok 1 - matches"); test_fail(+7); test_diag("No matching row returned"); test_diag("The SQL executed was:"); test_diag(" foo"); test_diag(" bar"); test_diag(" baz"); test_diag("on database 'bob'"); row_ok(dbh => FakeDBI->new(nomatch => 1), sql => "foo\nbar\nbaz", tests => [ "fooid" => 1 ], label => "matches", verbose => 1); test_test("no returned data verbose 1"); test_out("not ok 1 - matches"); test_fail(+5); test_diag("No matching row returned"); test_diag("The SQL executed was:"); test_diag(" SELECT * FROM foo WHERE fooid = qtd<1>"); test_diag("on database 'bob'"); row_ok(dbh => FakeDBI->new(nomatch => 1), table => "foo", where => [ "fooid" => 1 ], tests => [ "fooid" => 1 ], label => "matches", verbose => 1); test_test("no returned data verbose 2"); test_out("ok 1 - right"); row_ok(table => "dummy", where => [ dummy => "dummy" ], label => "wrong", description => "right"); test_test("description trumps label"); # fake database package package FakeDBI; sub new { my $class = shift; return bless { @_, Name => "bob" }, $class }; sub quote { return "qtd<$_[1]>" }; sub prepare { my $this = shift; # die if we need to if ($this->fallover) { die "Khaaaaaaaaaaaaan!" } return FakeSTH->new($this); } sub nomatch { return $_[0]->{nomatch} } sub fallover { return $_[0]->{fallover} } package FakeSTH; sub new { return bless { parent => $_[1] }, $_[0] }; sub execute { return 1 }; sub fetchrow_hashref { my $this = shift; my $parent = $this->{parent}; # return undef after the first call) if ($this->{called}) { return } else { $this->{called} = 1 } return ($parent->nomatch) ? () : { fooid => 123, name => "fred" } } Test-DatabaseRow-2.03/t/05warn.t000644 000765 000765 00000002553 11654176233 016270 0ustar00markmark000000 000000 #!/usr/bin/perl -w use strict; # check if we can run Test::Warn BEGIN { eval { require Test::Warn; Test::Warn->import }; if ($@) { print "1..0 # Skipped: no Test::Warn\n"; exit; } } $Test::DatabaseRow::dbh = FakeDBI->new(); use Test::More tests => 2; use Test::DatabaseRow; # eek, how confusing is this? This should produce two # oks, one for the row_ok and one for not finding any # warnings in it warning_is { row_ok(sql => "foo\nbar\nbaz", tests => [ "fooid" => 123, "wibble" => undef,], label => "inside test",); } "", "no warnings when dealing with undef/NULL"; # fake database package package FakeDBI; sub new { my $class = shift; return bless { @_, Name => "bob" }, $class }; sub quote { return "qtd<$_[1]>" }; sub prepare { my $this = shift; # die if we need to if ($this->fallover) { die "Khaaaaaaaaaaaaan!" } return FakeSTH->new($this); } sub nomatch { return $_[0]->{nomatch} } sub fallover { return $_[0]->{fallover} } package FakeSTH; sub new { return bless { parent => $_[1] }, $_[0] }; sub execute { return 1 }; sub fetchrow_hashref { my $this = shift; my $parent = $this->{parent}; # return undef after the first call) if ($this->{called}) { return } else { $this->{called} = 1 } return ($parent->nomatch) ? undef : { fooid => 123, name => "fred", wibble => undef} } Test-DatabaseRow-2.03/t/06multiple.t000644 000765 000765 00000011777 11656702677 017176 0ustar00markmark000000 000000 #!/usr/bin/perl -w use strict; use Test::More tests => 13; use Test::DatabaseRow; use Test::Builder::Tester; $Test::DatabaseRow::dbh = FakeDBI->new(results => 2); test_out("ok 1 - matches"); row_ok(table => "dummy", where => [ dummy => "dummy" ], tests => [ fooid => 123, name => "fred", name => qr/re/ ], label => "matches"); test_test("basic"); test_out("ok 1 - matches"); row_ok(table => "dummy", where => [ dummy => "dummy" ], results => 2, label => "matches"); test_test("right number"); test_out("ok 1 - matches"); row_ok(table => "dummy", where => [ dummy => "dummy" ], min_results => 2, label => "matches"); test_test("right number, min"); test_out("ok 1 - matches"); row_ok(table => "dummy", where => [ dummy => "dummy" ], max_results => 2, label => "matches"); test_test("right number, max"); test_out("not ok 1 - matches"); test_fail(+4); test_diag("Got the wrong number of rows back from the database."); test_diag(" got: 2 rows back"); test_diag(" expected: 3 rows back"); row_ok(table => "dummy", where => [ dummy => "dummy" ], results => 3, label => "matches"); test_test("wrong number"); test_out("not ok 1 - matches"); test_fail(+4); test_diag("Got too few rows back from the database."); test_diag(" got: 2 rows back"); test_diag(" expected: 3 rows or more back"); row_ok(table => "dummy", where => [ dummy => "dummy" ], min_results => 3, label => "matches"); test_test("wrong number, min"); test_out("not ok 1 - matches"); test_fail(+4); test_diag("Got too many rows back from the database."); test_diag(" got: 2 rows back"); test_diag(" expected: 1 rows or fewer back"); row_ok(table => "dummy", where => [ dummy => "dummy" ], max_results => 1, label => "matches"); test_test("wrong number, max"); $Test::DatabaseRow::dbh = FakeDBI->new(results => 0); test_out("ok 1 - matches"); not_row_ok(table => "dummy", where => [ dummy => "dummy" ], label => "matches"); test_test("not_row"); $Test::DatabaseRow::dbh = FakeDBI->new(results => 3); test_out("ok 1 - matches"); all_row_ok(table => "dummy", where => [ dummy => "dummy" ], tests => [ name => qr/e/ ], label => "matches"); test_test("all_row_ok pass"); test_out("not ok 1 - matches"); test_fail(+4); test_diag("While checking column 'name' on 2nd row"); test_diag(" got: 'bert'"); test_diag(" expected: 'fred'"); all_row_ok(table => "dummy", where => [ dummy => "dummy" ], tests => [ name => "fred" ], label => "matches"); test_test("all_row_ok fail"); test_out("not ok 1 - matches"); test_fail(+2); test_diag("No 4th row"); Test::DatabaseRow::Object->new( dbh => FakeDBI->new(results => 2), sql_and_bind => "dummy", )->row_at_index_ok(3)->pass_to_test_builder("matches"); test_test("missing row"); test_out("ok 1 - matches"); Test::DatabaseRow::Object->new( dbh => FakeDBI->new(results => 2), sql_and_bind => "dummy", )->row_at_index_ok(1)->pass_to_test_builder("matches"); test_test("row_at_index_ok with no tests"); $Test::DatabaseRow::dbh = FakeDBI->new(results => 4); # note the following test also checks undef <-> NULL handing test_out("not ok 1 - matches"); test_fail(+10); test_diag("While checking column 'gender' on 4th row"); test_diag(" got: NULL"); test_diag(" expected: 'm'"); test_diag("The SQL executed was:"); test_diag(" dummy sql"); test_diag("The bound parameters were:"); test_diag(" '7'"); test_diag(" undef"); test_diag("on database 'fakename'"); all_row_ok( sql => ["dummy sql",7,undef], tests => [ gender => "m" ], label => "matches", verbose => 1, ); test_test("verbose"); # fake database package package FakeDBI; sub new { my $class = shift; return bless { @_, Name => "fakename" }, $class }; sub quote { return "qtd<$_[1]>" }; sub prepare { my $this = shift; # die if we need to if ($this->fallover) { die "Khaaaaaaaaaaaaan!" } return FakeSTH->new($this); } sub results { return $_[0]->{results} } sub nomatch { return $_[0]->{nomatch} } sub fallover { return $_[0]->{fallover} } package FakeSTH; sub new { return bless { parent => $_[1] }, $_[0] }; sub execute { return 1 }; sub fetchrow_hashref { my $this = shift; my $parent = $this->{parent}; $this->{returned}++; return if $parent->nomatch; return if $this->{returned} > $parent->results; if ($this->{returned} == 1) { return { fooid => 123, name => "fred", gender => 'm'} } if ($this->{returned} == 2) { return { fooid => 124, name => "bert", gender => 'm'} } if ($this->{returned} == 3) { return { fooid => 125, name => "ernie", gender => 'm'} } if ($this->{returned} == 4) { return { fooid => 125, name => undef, gender => undef } } # oops, someone wanted more results than we prepared return; } Test-DatabaseRow-2.03/t/07results.t000644 000765 000765 00000005621 11656702676 017033 0ustar00markmark000000 000000 #!/usr/bin/perl ######################################################################## # this tesst checks that store_XXX in Test::DatabaseRow's row_ok # functions works ######################################################################## use strict; use warnings; use Test::More tests => 10; use Test::DatabaseRow; use Test::Builder::Tester; use Data::Dumper; $Test::DatabaseRow::dbh = FakeDBI->new(results => 2); ######################################################################## my @rows; test_out("ok 1 - matches"); row_ok(table => "dummy", where => [ dummy => "dummy" ], results => 2, label => "matches", store_rows => \@rows); test_test("array"); is_deeply(\@rows, [ { fooid => 123, name => "fred" }, { fooid => 124, name => "bert" }, ]); ######################################################################## my $row; test_out("ok 1 - matches"); row_ok(table => "dummy", where => [ dummy => "dummy" ], results => 2, label => "matches", store_row => \$row); test_test("scalar"); is_deeply($row, { fooid => 123, name => "fred" }); test_out("ok 1 - matches"); row_ok(table => "dummy", where => [ dummy => "dummy" ], results => 2, label => "matches", store_row => \$row); test_test("scalar"); is_deeply($row, { fooid => 123, name => "fred" }); my %row; test_out("ok 1 - matches"); row_ok(table => "dummy", where => [ dummy => "dummy" ], results => 2, label => "matches", store_row => \%row); test_test("hash"); is_deeply(\%row, { fooid => 123, name => "fred" }); $row = {}; test_out("ok 1 - matches"); row_ok(table => "dummy", where => [ dummy => "dummy" ], results => 2, label => "matches", store_row => \$row); test_test("ref"); is_deeply($row, { fooid => 123, name => "fred" }); ######################################################################## # fake database package package FakeDBI; sub new { my $class = shift; return bless { @_ }, $class }; sub quote { return "qtd<$_[1]>" }; sub prepare { my $this = shift; # die if we need to if ($this->fallover) { die "Khaaaaaaaaaaaaan!" } return FakeSTH->new($this); } sub results { return $_[0]->{results} } sub nomatch { return $_[0]->{nomatch} } sub fallover { return $_[0]->{fallover} } package FakeSTH; sub new { return bless { parent => $_[1] }, $_[0] }; sub execute { return 1 }; sub fetchrow_hashref { my $this = shift; my $parent = $this->{parent}; $this->{returned}++; return if $parent->nomatch; return if $this->{returned} > $parent->results; if ($this->{returned} == 1) { return { fooid => 123, name => "fred" } } if ($this->{returned} == 2) { return { fooid => 124, name => "bert" } } if ($this->{returned} == 3) { return { fooid => 125, name => "ernie" } } # oops, someone wanted more results than we prepared return; } Test-DatabaseRow-2.03/t/08utf8.t000644 000765 000765 00000003560 11654176373 016216 0ustar00markmark000000 000000 #!/usr/bin/perl -w use strict; use Test::More; # these tests only work on perl 5.8.0 BEGIN { if( $] < 5.007 ) { plan skip_all => 'need perl 5.8 for utf8 hacks' } else { plan tests => 2; } } use utf8; use Test::DatabaseRow; use Test::Builder::Tester; # stderr needs to be utf8 so I can read these errors binmode STDERR, ":utf8"; $Test::DatabaseRow::dbh = FakeDBI->new(results => 2); test_out("ok 1 - foo"); row_ok(table => "dummy", where => [ dummy => "dummy" ], tests => [ name => "Napol\x{e9}on" ], label => "foo", force_utf8 => 1); test_test("napoleon"); $Test::DatabaseRow::force_utf8 = 1; test_out("ok 1 - foo"); row_ok(table => "dummy", where => [ dummy => "dummy" ], tests => [ beast => "m\x{f8}\x{f8}se" ], label => "foo", force_utf8 => 1); test_test("moose"); # fake database package package FakeDBI; sub new { my $class = shift; return bless { @_ }, $class }; sub quote { return "qtd<$_[1]>" }; sub prepare { my $this = shift; # die if we need to if ($this->fallover) { die "Khaaaaaaaaaaaaan!" } return FakeSTH->new($this); } sub results { return $_[0]->{results} } sub nomatch { return $_[0]->{nomatch} } sub fallover { return $_[0]->{fallover} } package FakeSTH; sub new { return bless { parent => $_[1] }, $_[0] }; sub execute { return 1 }; sub fetchrow_hashref { my $this = shift; my $parent = $this->{parent}; $this->{returned}++; return if $parent->nomatch; return if $this->{returned} > $parent->results; # we're creating utf8 strings by directly writing in the # utf8 bytes. This gives us utf8 strings we're testing # against, but without the utf8 flag set no utf8; if ($this->{returned} == 1) { return { name => "Napol\x{c3}\x{a9}on", beast => "m\x{c3}\x{b8}\x{c3}\x{b8}se" } } # oops, someone wanted more results than we prepared return; } Test-DatabaseRow-2.03/t/09has.t000644 000765 000765 00000002575 11715142062 016073 0ustar00markmark000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 28; BEGIN { use_ok "Test::DatabaseRow::Object" } BEGIN { use_ok "Test::DatabaseRow::Result" } { my $tbr = Test::DatabaseRow::Object->new(); foreach my $field (qw( db_results sql_and_bind dbh table where verbose force_utf8 tests results max_results min_results )) { my $method = "has_$field"; ok(!$tbr->$method, "hasn't $field") } } { my $tbr = Test::DatabaseRow::Object->new( label => "foo", db_results => [], sql_and_bind => [], dbh => "dummy", table => "foo", where => [ 1 => 1 ], verbose => 0, force_utf8 => 0, tests => [], results => 9, max_results => 9, min_results => 9, ); foreach my $field (qw( db_results sql_and_bind dbh table where verbose force_utf8 tests results max_results min_results )) { my $method = "has_$field"; ok($tbr->$method, "has $field") } } { my $tbr = Test::DatabaseRow::Result->new(); foreach my $field (qw( is_error diag )) { my $method = "has_$field"; ok(!$tbr->$method, "hasn't $field") } } { my $tbr = Test::DatabaseRow::Result->new( is_error => 0, diag => [], ); foreach my $field (qw( is_error diag )) { my $method = "has_$field"; ok($tbr->$method, "has $field") } } Test-DatabaseRow-2.03/t/10result.t000644 000765 000765 00000001642 11656702677 016642 0ustar00markmark000000 000000 #!/usr/bin/perl ######################################################################## # this test simply tests the Test::DatabaseRow::Result object ######################################################################## use strict; use warnings; use Test::More tests => 10; BEGIN { use_ok("Test::DatabaseRow::Result") }; { my $result = Test::DatabaseRow::Result->new(); isa_ok($result, "Test::DatabaseRow::Result"); ok(!$result->is_error, "Not is_error"); ok($result->is_success, "Is is_success"); is_deeply($result->diag, [], "diag"); } { my $result = Test::DatabaseRow::Result->new( is_error => 1, diag => [ "foo", "bar" ]); isa_ok($result, "Test::DatabaseRow::Result"); ok($result->is_error, "Is is_error"); ok(!$result->is_success, "Not is_success"); is_deeply($result->diag, [ "foo", "bar" ], "diag"); $result->add_diag("bazz","buzz"); is_deeply($result->diag, [ "foo", "bar","bazz","buzz" ], "diag"); }Test-DatabaseRow-2.03/t/11th.t000644 000765 000765 00000003567 11656702676 015747 0ustar00markmark000000 000000 #!/usr/bin/perl ######################################################################## # this code tests the code I stole from # Lingua::EN::Numbers::Ordiante # - one of the disadvantages of stealing code rather than # listing it as a dependancy is you have to supply your own tests! ######################################################################## use strict; use warnings; use Test::More tests => 202; use Test::DatabaseRow::Object; my $count = 0; while () { chomp; $count++; is($count.Test::DatabaseRow::Object::_th($count), $_, $_); } is(Test::DatabaseRow::Object::_th(undef),"th"); is(Test::DatabaseRow::Object::_th(3.141),"th"); # silence the warning in the text; Should get it in real world usage local $SIG{__WARN__} = sub {}; is(Test::DatabaseRow::Object::_th("fish"),"th"); __DATA__ 1st 2nd 3rd 4th 5th 6th 7th 8th 9th 10th 11th 12th 13th 14th 15th 16th 17th 18th 19th 20th 21st 22nd 23rd 24th 25th 26th 27th 28th 29th 30th 31st 32nd 33rd 34th 35th 36th 37th 38th 39th 40th 41st 42nd 43rd 44th 45th 46th 47th 48th 49th 50th 51st 52nd 53rd 54th 55th 56th 57th 58th 59th 60th 61st 62nd 63rd 64th 65th 66th 67th 68th 69th 70th 71st 72nd 73rd 74th 75th 76th 77th 78th 79th 80th 81st 82nd 83rd 84th 85th 86th 87th 88th 89th 90th 91st 92nd 93rd 94th 95th 96th 97th 98th 99th 100th 101st 102nd 103rd 104th 105th 106th 107th 108th 109th 110th 111th 112th 113th 114th 115th 116th 117th 118th 119th 120th 121st 122nd 123rd 124th 125th 126th 127th 128th 129th 130th 131st 132nd 133rd 134th 135th 136th 137th 138th 139th 140th 141st 142nd 143rd 144th 145th 146th 147th 148th 149th 150th 151st 152nd 153rd 154th 155th 156th 157th 158th 159th 160th 161st 162nd 163rd 164th 165th 166th 167th 168th 169th 170th 171st 172nd 173rd 174th 175th 176th 177th 178th 179th 180th 181st 182nd 183rd 184th 185th 186th 187th 188th 189th 190th 191st 192nd 193rd 194th 195th 196th 197th 198th 199th Test-DatabaseRow-2.03/lib/Test/000755 000765 000765 00000000000 11715142631 016175 5ustar00markmark000000 000000 Test-DatabaseRow-2.03/lib/Test/DatabaseRow/000755 000765 000765 00000000000 11715142631 020371 5ustar00markmark000000 000000 Test-DatabaseRow-2.03/lib/Test/DatabaseRow.pm000644 000765 000765 00000045402 11715142531 020733 0ustar00markmark000000 000000 package Test::DatabaseRow; # require at least a version of Perl that is merely ancient, but not # prehistoric use 5.006; use strict; use warnings; # set row_ok to be exported use base qw(Exporter); our @EXPORT; use Carp qw(croak); our @CARP_OK = qw(Test::DatabaseRow TestDatabaseRow::Object); # set the version number our $VERSION = "2.03"; use Test::DatabaseRow::Object; our $object_class = "Test::DatabaseRow::Object"; sub row_ok { # horrible, horrible package vars # In 2003 Mark Fowler chose to make a procedual interface # to this module and keep state in package vars to make the # interface easy. In 2011 Mark Fowler isn't sure this is # a great idea our $dbh; our $force_utf8; our $verbose; # defaults my %args = ( dbh => $dbh, force_utf8 => $force_utf8, verbose => $verbose || $ENV{TEST_DBROW_VERBOSE}, check_all_rows => 0, @_ ); # rename "sql" to "sql_and_bind" # (it's called just sql for legacy reasons) $args{sql_and_bind} = $args{sql} if exists $args{sql} && !exists $args{sql_and_bind}; # remove description, provide default fallback from label my $label = delete $args{label}; my $description = delete $args{description}; $description = $label unless defined $description; $description = "simple db test" unless defined $description; # do the test my $tbr = $object_class->new(%args); my $tbr_result = $tbr->test_ok(); # store the results of the database operation in a var passed # into this function. # # This is another example of functionality that is difficult # to add to a procedural interface and would have been easier # if I'd used an OO interface. That's the problem with # published APIs though, isn't it? It's hard to change them if ($args{store_rows}) { croak "Must pass an arrayref in 'store_rows'" unless ref $args{store_rows} eq "ARRAY"; @{ $args{store_rows} } = @{ $tbr->db_results }; } if ($args{store_row}) { if (ref $args{store_row} eq "HASH") { %{ $args{store_row} } = %{ $tbr->db_results->[0] }; } elsif (ref $args{store_row} eq "SCALAR" && !defined ${ $args{store_row} }) { ${ $args{store_row} } = $tbr->db_results->[0]; } elsif (ref $args{store_row} eq "REF" && ref ${ $args{store_row} } eq "HASH" ) { %{${ $args{store_row} }} = %{ $tbr->db_results->[0] }; } else { croak "Invalid argument passed in 'store_row'"; } } # render the result with Test::Builder local $Test::Builder::Level = $Test::Builder::Level + 1; return $tbr_result->pass_to_test_builder( $description ); } push @EXPORT, qw(row_ok); sub not_row_ok { local $Test::Builder::Level = $Test::Builder::Level + 1; return row_ok(@_, results => 0); } push @EXPORT, qw(not_row_ok); sub all_row_ok { local $Test::Builder::Level = $Test::Builder::Level + 1; return row_ok(@_, check_all_rows => 1); } push @EXPORT, qw(all_row_ok); # truth at end of the module 1; __END__ =head1 NAME Test::DatabaseRow - simple database tests =head1 SYNOPSIS use Test::More tests => 3; use Test::DatabaseRow; # set the default database handle local $Test::DatabaseRow::dbh = $dbh; # sql based test all_row_ok( sql => "SELECT * FROM contacts WHERE cid = '123'", tests => [ name => "trelane" ], description => "contact 123's name is trelane" ); # test with shortcuts all_row_ok( table => "contacts", where => [ cid => 123 ], tests => [ name => "trelane" ], description => "contact 123's name is trelane" ); # complex test all_row_ok( table => "contacts", where => { '=' => { name => "trelane" }, 'like' => { url => '%shortplanks.com' },}, tests => { '==' => { cid => 123, num => 134 }, 'eq' => { person => "Mark Fowler" }, '=~' => { road => qr/Liverpool R.?.?d/ },}, description => "trelane entered into contacts okay" ); ); =head1 DESCRIPTION This is a simple module for doing simple tests on a database, primarily designed to test if a row exists with the correct details in a table or not. This module exports several functions. =head2 row_ok The C function takes named attributes that control which rows in which table it selects, and what tests are carried out on those rows. By default it performs the tests against only the first row returned from the database, but parameters passed to it can alter that behavior. =over 4 =item dbh The database handle that the test should use. In lieu of this attribute being passed the test will use whatever handle is set in the C<$Test::DatabaseRow::dbh> global variable. =item sql Manually specify the SQL to select the rows you want this module to execute. This can either be just a plain string, or it can be an array ref with the first element containing the SQL string and any further elements containing bind variables that will be used to fill in placeholders. # using the plain string version row_ok(sql => "SELECT * FROM contacts WHERE cid = '123'", tests => [ name => "Trelane" ]); # using placeholders and bind variables row_ok(sql => [ "SELECT * FROM contacts WHERE cid = ?", 123 ], tests => [ name => "Trelane" ]); =item table Build the SELECT statement programmatically. This parameter contains the name of the table the SELECT statement should be executed against. You cannot pass both a C parameter and a C parameter. If you specify C
you B pass a C parameter also (see below.) =item where Build the SELECT statement programmatically. This parameter should contain options that will combine into a WHERE clause in order to select the row that you want to test. This options normally are a hash of hashes. It's a hashref keyed by SQL comparison operators that has in turn values that are further hashrefs of column name and values pairs. This sounds really complicated, but is quite simple once you've been shown an example. If we could get get the data to test with a SQL like so: SELECT * FROM tablename WHERE foo = 'bar' AND baz = 23 AND fred LIKE 'wilma%' AND age >= 18 Then we could have the function build that SQL like so: row_ok(table => "tablename", where => { '=' => { foo => "bar", baz => 23, }, 'LIKE' => { fred => 'wimla%', }, '>=' => { age => '18', },}); Note how each different type of comparison has it's own little hashref containing the column name and the value for that column that the associated operator SQL should search for. This syntax is quite flexible, but can be overkill for simple tests. In order to make this simpler, if you are only using '=' tests you may just pass an arrayref of the column names / values. For example, just to test SELECT * FROM tablename WHERE foo = 'bar' AND baz = 23; You can simply pass row_ok(table => "tablename", where => [ foo => "bar", baz => 23, ]); Which, in a lot of cases, makes things a lot quicker and simpler to write. NULL values can confuse things in SQL. All you need to remember is that when building SQL statements use C whenever you want to use a NULL value. Don't use the string "NULL" as that'll be interpreted as the literal string made up of a N, a U and two Ls. As a special case, using C either in a C<=> or in the short arrayref form will cause a "IS" test to be used instead of a C<=> test. This means the statements: row_ok(table => "tablename", where => [ foo => undef ],) Will produce: SELECT * FROM tablename WHERE foo IS NULL =item tests The comparisons that you want to run between the expected data and the data in the first line returned from the database. If you do not specify any tests then the test will simply check if I rows are returned from the database and will pass no matter what they actually contain. Normally this is a hash of hashes in a similar vein to C. This time the outer hash is keyed by Perl comparison operators, and the inner hashes contain column names and the expected values for these columns. For example: row_ok(sql => $sql, tests => { "eq" => { wibble => "wobble", fish => "fosh", }, "==" => { bob => 4077 }, "=~" => { fred => qr/barney/ },},); This checks that the column wibble is the string "wobble", column fish is the string "fosh", column bob is equal numerically to 4077, and that fred contains the text "barney". You may use any infix comparison operator (e.g. "<", ">", "&&", etc, etc) as a test key. The first comparison to fail (to return false) will cause the whole test to fail, and debug information will be printed out on that comparison. In a similar fashion to C you can also pass a arrayref for simple comparisons. The function will try and Do The Right Thing with regard to the expected value for that comparison. Any expected value that looks like a number will be compared numerically, a regular expression will be compared with the C<=~> operator, and anything else will undergo string comparison. The above example therefore could be rewritten: row_ok(sql => $sql, tests => [ wibble => "wobble", fish => "fosh", bob => 4077, fred => qr/barney/ ]); =item check_all_rows Setting this to a true value causes C to run the tests against all rows returned from the database not just the first. =item verbose Setting this option to a true value will cause verbose diagnostics to be printed out during any failing tests. You may also enable this feature by setting either C<$Test::DatabaseRow::verbose> variable the C environmental variable to a true value. =item store_rows Sometimes, it's not enough to just use the simple tests that B offers you. In this situation you can use the C function to get at the results that row_ok has extracted from the database. You should pass a reference to an array for the results to be stored in; After the call to C this array will be populated with one hashref per row returned from the database, keyed by column names. row_ok(sql => "SELECT * FROM contact WHERE name = 'Trelane'", store_rows => \@rows); ok(Email::Valid->address($rows[0]{'email'})); =item store_row The same as C, but only the stores the first row returned in the variable. Instead of passing in an array reference you should pass in either a reference to a hash... row_ok(sql => "SELECT * FROM contact WHERE name = 'Trelane'", store_rows => \%row); ok(Email::Valid->address($row{'email'})); ...or a reference to a scalar which should be populated with a hashref... row_ok(sql => "SELECT * FROM contact WHERE name = 'Trelane'", store_rows => \$row); ok(Email::Valid->address($row->{'email'})); =item description The description that this test will use with C, i.e the thing that will be printed out after ok/not ok. For example: row_ok( sql => "SELECT * FROM queue", description => "something in the queue" ); Hopefully produces something like: ok 1 - something in the queue For historical reasons you may also pass C
accessors. =item dbh The database handle used to execute the SQL statement in C if no C were passed. =item table The table name used to build the SQL query if no value is passed to C. String. =item where The data structure used to build the where clause of the SQL query if no value is passed to . This accessor value should be a hashref of hashrefs, with the outer keys being the SQL comparison operator, the inner keys being the field names and the inner values being the values to match against. For example: { '=' => { first => "Fred", last => "Flintstone", }, 'like' => { address => "%Bedrock%" }, } Values of C will automatically converted into checks for NULLs. This accessor automatically coerces array refs that are passed into a pure equals hashref. For example: [ foo => "bar", bazz => "buzz" ] Will be coerced into: { "=" => { foo => "bar", bazz => "buzz" } } See L for a more detailed explanation. =item verbose Truth value, default false. Controls if the diagnostic messages printed during C on failure contain details of the SQL executed or not. =item force_utf8 Truth value, default false. Controls if the utf8 flag should be turned on on values returned from the database. See L for why this might be important. This flag only effects data that this module places into C. If you manually populate this accessor this flag will have no effect. =item tests If set, enables specified tests on the first element of C when C is called. This accessor value should be a hashref of hashrefs, with the outer keys being the Perl comparison operator, the inner keys being the field names and the inner values being the values to test against. For example: { 'eq' => { first => "Fred", last => "Flintstone", }, '=~' => { address => "%Bedrock%" }, } This accessor automatically coerces array refs that are passed into a hashref structure, converting things that look like strings into C tests, things that look like numbers into C<==> tests and things that are references to regular expressions into C<=~> tests. Foe example: [ num => 123, letters => "abc", kinda => qr/substring/ ] Will be coerced into { '==' => { num => 123, }, 'eq' => { letters => "abc", }, '=~' => { kinda => qr/substring/ }, } See L for a more detailed explanation. =item check_all_rows Boolean to determine if we should test all rows (during C and C) or just check the first row. Default true. =item results If set, enable tests to check the number of rows we returned by C is exactly this value when C is called. Integer. =item max_results If set, enable tests to check the number of rows we returned by C is at most this value when C is called. Integer. =item min_results If set, enable tests to check the number of rows we returned by C is at least this value when C is called. Integer. =back =head2 Methods =over =item new(...) Simple constructor. Passing arguments to the constructor sets the values of the accessors. =item number_of_results_ok Returns a Test::DatabaseRow::Result that represents if the number of results in C match the requirements for the number of results. =item row_at_index_ok( $row_index ) Returns a Test::DatabaseRow::Result that represents if the element corresponding to the passed row index in C match the tests defined in C. =item db_results_ok Returns a Test::DatabaseRow::Result that represents if all elements in C match the tests defined in C. =item test_ok Returns a Test::DatabaseRow::Result that represents if the number of results in C match the requirements for the number of results and all elements in C match the tests defined in C. =back =head1 BUGS Bugs (and requests for new features) can be reported though the CPAN RT system: L Alternatively, you can simply fork this project on github and send me pull requests. Please see =head1 AUTHOR Written by Mark Fowler B Copyright Profero 2003, 2004. Copyright Mark Fowler 2011. Some code taken from B, written by Michael Schwern. Some code taken from B, written by Damian Conway. Neither objected to its inclusion in this module. Some code taken from B, written by Sean M. Burke. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L, L =cutTest-DatabaseRow-2.03/lib/Test/DatabaseRow/Result.pm000644 000765 000765 00000007324 11656762311 022222 0ustar00markmark000000 000000 package Test::DatabaseRow::Result; use strict; use warnings; our $VERSION = "2.01"; use Carp qw(croak); ## constructor ######################################################### # emulate moose somewhat by calling a _coerce_and_verify_XXX method # if one exists sub new { my $class = shift; my $self = bless {}, $class; while (@_) { my $key = shift; my $value = shift; my $method = $self->can("_coerce_and_verify_$key"); $self->{ $key } = $method ? $method->($self,$value) : $value; } return $self; } ## accessors ############################################################ # has is_error => ( is => "ro", isa => "Bool", default => 0, # predicate => 'has_error' ) sub is_error { my $self = shift; $self->{is_error} ||= 0; return $self->{is_error}; } sub has_is_error { my $self = shift; return exists $self->{is_error} } # has diag => ( is => "rw", isa => "ArrayRef", default => sub {[]}, # predicate => "has_diag", # traits => ['Array'], handles => { add_diag => 'push' }) sub diag { my $self = shift; $self->{diag} ||= []; return $self->{diag}; } sub has_diag { my $self = shift; return exists $self->{diag} } sub _coerce_and_verify_diag { my $self = shift; my $diag = shift; croak "Invalid argument to diag" unless ref($diag) eq "ARRAY"; return $diag; } sub add_diag { my $self = shift; push @{ $self->diag }, @_; return; } ## methods ############################################################# sub pass_to_test_builder { my $self = shift; my $description = shift; # get the test builder singleton my $tester = Test::Builder->new(); my $result = $tester->ok($self->is_success, $description); $tester->diag($_) foreach @{ $self->diag }; return $result; } sub is_success { my $self = shift; return !$self->is_error; } 1; __END__ =head1 NAME Test::DatabaseRow::Result - represent the result of some db testing =head1 SYNOPSIS use Test::More tests => 1; use Test::DatabaseRow::Result; # create a test results my $result_object = Test::DatabaseRow::Result->new( is_error => 1, diag => [ "The WHAM overheaded!" ] ); # have those results render to Test::Builder $result_object->pass_to_test_builder("fire main gun"); =head1 DESCRIPTION This module is used by Test::DatabaseRow::Object to represent the result of a test. =head2 Accessors These are the read only accessors of the object. They may be (optionally) set at object creation time by passing their name and value to the constructor. Each accessor may be queried by prefixing its name with the C to determine =over =item is_error Boolean representing if this is an error or not. =item diag An arrayref containing diagnostic error strings that can help explain any error. =back =head2 Methods =over =item new(...) Simple constructor. Passing arguments to the constructor sets the values of the accessors. =item add_diag( @diagnostics ) Adds extra diagnostics to the C array. =item pass_to_test_builder( $description ) Causes this test to render itself out using C =item is_success Returns true if and only if C is false. =back =head1 BUGS Bugs (and requests for new features) can be reported though the CPAN RT system: L Alternatively, you can simply fork this project on github and send me pull requests. Please see =head1 AUTHOR Written by Mark Fowler B Copyright Mark Fowler 2011. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L, L =cutTest-DatabaseRow-2.03/inc/Module/000755 000765 000765 00000000000 11715142631 016506 5ustar00markmark000000 000000 Test-DatabaseRow-2.03/inc/Module/Install/000755 000765 000765 00000000000 11715142631 020114 5ustar00markmark000000 000000 Test-DatabaseRow-2.03/inc/Module/Install.pm000644 000765 000765 00000030135 11715142567 020464 0ustar00markmark000000 000000 #line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.00'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2010 Adam Kennedy. Test-DatabaseRow-2.03/inc/Module/Install/AuthorTests.pm000644 000765 000765 00000002215 11715142567 022747 0ustar00markmark000000 000000 #line 1 package Module::Install::AuthorTests; use 5.005; use strict; use Module::Install::Base; use Carp (); #line 16 use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.002'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } #line 42 sub author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 0); } #line 56 sub recursive_author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 1); } sub _wanted { my $href = shift; sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 } } sub _add_author_tests { my ($self, $dirs, $recurse) = @_; return unless $Module::Install::AUTHOR; my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t'; # XXX: pick a default, later -- rjbs, 2008-02-24 my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests"; @dirs = grep { -d } @dirs; if ($recurse) { require File::Find; my %test_dir; File::Find::find(_wanted(\%test_dir), @dirs); $self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir ); } else { $self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs ); } } #line 107 1; Test-DatabaseRow-2.03/inc/Module/Install/Base.pm000644 000765 000765 00000002147 11715142567 021340 0ustar00markmark000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.00'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Test-DatabaseRow-2.03/inc/Module/Install/Can.pm000644 000765 000765 00000003333 11715142567 021165 0ustar00markmark000000 000000 #line 1 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.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 Test-DatabaseRow-2.03/inc/Module/Install/Fetch.pm000644 000765 000765 00000004627 11715142567 021524 0ustar00markmark000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Test-DatabaseRow-2.03/inc/Module/Install/GithubMeta.pm000644 000765 000765 00000002041 11715142567 022510 0ustar00markmark000000 000000 #line 1 package Module::Install::GithubMeta; use strict; use warnings; use Cwd; use base qw(Module::Install::Base); use vars qw($VERSION); $VERSION = '0.10'; sub githubmeta { my $self = shift; return unless $Module::Install::AUTHOR; return unless _under_git(); return unless $self->can_run('git'); return unless my ($git_url) = `git remote show -n origin` =~ /URL: (.*)$/m; return unless $git_url =~ /github\.com/; # Not a Github repository my $http_url = $git_url; $git_url =~ s![\w\-]+\@([^:]+):!git://$1/!; $http_url =~ s![\w\-]+\@([^:]+):!http://$1/!; $http_url =~ s!\.git$!/tree!; $self->repository( $git_url ); $self->homepage( $http_url ) unless $self->homepage(); return 1; } sub _under_git { return 1 if -e '.git'; my $cwd = getcwd; my $last = $cwd; my $found = 0; while (1) { chdir '..' or last; my $current = getcwd; last if $last eq $current; $last = $current; if ( -e '.git' ) { $found = 1; last; } } chdir $cwd; return $found; } 'Github'; __END__ #line 108 Test-DatabaseRow-2.03/inc/Module/Install/Makefile.pm000644 000765 000765 00000027032 11715142567 022203 0ustar00markmark000000 000000 #line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT $DB::single = 1; if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 541 Test-DatabaseRow-2.03/inc/Module/Install/Metadata.pm000644 000765 000765 00000043020 11715142567 022201 0ustar00markmark000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', 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, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( \Qhttp://rt.cpan.org/\E[^>]+| \Qhttp://github.com/\E[\w_]+/[\w_]+/issues| \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Test-DatabaseRow-2.03/inc/Module/Install/Win32.pm000644 000765 000765 00000003403 11715142567 021364 0ustar00markmark000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Test-DatabaseRow-2.03/inc/Module/Install/WriteAll.pm000644 000765 000765 00000002376 11715142567 022215 0ustar00markmark000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1;