DBIx-Class-Schema-PopulateMore-0.19/000755 000766 000024 00000000000 12415571446 017217 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/Changes000644 000766 000024 00000006145 12415565533 020520 0ustar00johnstaff000000 000000 Revision history for Perl extension DBIx-Class-Schema-PopulateMore. 0.19 Thursday, October 9, 2014 - increase some dependency minimum version to solve some reported test fails. 0.18 Wednesday, June 4, 2014 - Port to Moo - documentation typo fixes - fixed a bug ...::Command where some code was not immutable 0.17 Monday, May 9, 2011 - Changed column definition from integer to varchar since that column takes characters as well as numbers and the newest DBIC enforces this. 0.16 Thursday, February 24, 2011 - update copyright info - migration to new Module::Install maint tools - Updated dependencies to modern and supportable versions - modernized some schema code practices 0.15 Tuesday, August 24, 2010 - Use more modern Moose stuff and updated to modern dependencies. - formatting changes (no tabs, etc.) - fixed some author only test failures 0.14 Monday, August 17, 2009 - Increased the flexibility of allowed incoming arguments and documented this change. Added test for this format. 0.13 Monday, July 6, 2009 - Fix an error with the way we parse command inflators so that if a source string contains '::' it won't give us the wrong lookup index - Changed from using 'confess' to using the DBIC throw exception method - More minor documentation updates. 0.12 Tuesday, June 30, 2009 - More tweaks to try and fix my broken local Module::Install 0.11 Monday, June 29, 2009 - Minor doc changes and dependency tweaks to fix more cpan fails 0.10 Sunday, June 28, 2009 - changed the find inflator to allow multikey finds - more Makefile.PL tweaks to solve some cpan reported errors 0.09 Friday, June 26, 2009 - Added a Find inflator, with docs and a test case 0.08 Friday, June 26, 2009 - Fixed some documentation issues - fixed the copyright - arguments now allowed to be both array and arrayref. This should reduce some line noise in some config file types or if you are just using a perl structure. 0.07 Friday, June 26, 2009 - Add a placeholder to make sure the t/var directory is around at test time. 0.06 Thursday, June 25, 2009 - Added SQLT to the build recommends, otherwise tests fail 0.05 Thursday, June 25, 2009 - Updated all the required versions to more recent items, since that is what I can test on, plus most of that older stuff has known compatibility issues. - Requires Perl 5.8.8 since I can't test this on 5.8.6 anywhere (patches or test cases welcomed.) - changed the way we set default timestamp on sqlite. this fixes a lot of failed test cases. Now all tests pass for me and I cleared most of the types of test failues I see in the backlog. - Updated Docs a bit. 0.04 Friday, June 04, 2008 - Moved namespace of component from DBIx-Class-PopulateMore - Minor documentation updates 0.03 Friday, May 29, 2008 - Fixed missing dependencies from Makefile.PL - Documentation and example improvements 0.02 Friday, May 29, 2008 - Fix for messed up POD and missing Makefile.PL 0.01 Friday, May 29, 2008 - Initial release DBIx-Class-Schema-PopulateMore-0.19/inc/000755 000766 000024 00000000000 12415571446 017770 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/lib/000755 000766 000024 00000000000 12415571446 017765 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/LICENSE000644 000766 000024 00000044023 12415571430 020220 0ustar00johnstaff000000 000000 This software is copyright (c) 2014 by John Napiorkowski, C<< >>. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2014 by John Napiorkowski, C<< >>. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2014 by John Napiorkowski, C<< >>. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End DBIx-Class-Schema-PopulateMore-0.19/maint/000755 000766 000024 00000000000 12415571446 020327 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/Makefile.PL000644 000766 000024 00000001503 12415565624 021171 0ustar00johnstaff000000 000000 #!/usr/bin/env perl use strict; use warnings FATAL => 'all'; use inc::Module::Install; requires 'parent' => '0.224'; requires 'Moo' => '1.004006'; requires 'MooX::HandlesVia' => '0.001005'; requires 'Scalar::Util' => '1.35'; requires 'Type::Tiny' => '0.042'; requires 'DateTimeX::Easy' => '0.089'; requires 'List::MoreUtils' => '0.30'; requires 'Module::Pluggable' => '3.9'; test_requires 'DBIx::Class' => '0.08127'; test_requires 'DateTime::Format::SQLite' => '0.11'; ## needed by DBIC for datetime in/deflators test_requires 'SQL::Translator' => '0.11020'; test_requires 'Test::More' => '0.98'; test_requires 'File::Find'; test_requires 'YAML::Tiny' => '1.48'; test_requires 'Path::Class' => '0.23'; all_from 'lib/DBIx/Class/Schema/PopulateMore.pm'; require 'maint/Makefile.PL.include' if $Module::Install::AUTHOR; WriteAll; DBIx-Class-Schema-PopulateMore-0.19/MANIFEST000644 000766 000024 00000003403 12415571446 020350 0ustar00johnstaff000000 000000 Changes inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/AutoLicense.pm inc/Module/Install/AutoManifest.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Homepage.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/ManifestSkip.pm inc/Module/Install/Metadata.pm inc/Module/Install/ReadmeMarkdownFromPod.pm inc/Module/Install/Repository.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm inc/Pod/Markdown.pm lib/DBIx/Class/Schema/PopulateMore.pm lib/DBIx/Class/Schema/PopulateMore/Command.pm lib/DBIx/Class/Schema/PopulateMore/Inflator.pm lib/DBIx/Class/Schema/PopulateMore/Inflator/Date.pm lib/DBIx/Class/Schema/PopulateMore/Inflator/Env.pm lib/DBIx/Class/Schema/PopulateMore/Inflator/Find.pm lib/DBIx/Class/Schema/PopulateMore/Inflator/Index.pm lib/DBIx/Class/Schema/PopulateMore/Test/Schema.pm lib/DBIx/Class/Schema/PopulateMore/Test/Schema/Result.pm lib/DBIx/Class/Schema/PopulateMore/Test/Schema/Result/Company.pm lib/DBIx/Class/Schema/PopulateMore/Test/Schema/Result/CompanyPerson.pm lib/DBIx/Class/Schema/PopulateMore/Test/Schema/Result/EmploymentHistory.pm lib/DBIx/Class/Schema/PopulateMore/Test/Schema/Result/FriendList.pm lib/DBIx/Class/Schema/PopulateMore/Test/Schema/Result/Gender.pm lib/DBIx/Class/Schema/PopulateMore/Test/Schema/Result/Person.pm lib/DBIx/Class/Schema/PopulateMore/Test/Schema/ResultSet.pm lib/DBIx/Class/Schema/PopulateMore/Test/Schema/ResultSet/Person.pm lib/DBIx/Class/Schema/PopulateMore/Visitor.pm LICENSE maint/Makefile.PL.include Makefile.PL MANIFEST This list of files META.yml README.mkdn t/00-load.t t/01-schema.t t/02-yaml_example.t t/author/newlines.t t/author/pod-coverage.t t/author/pod.t t/var/README DBIx-Class-Schema-PopulateMore-0.19/META.yml000644 000766 000024 00000002131 12415571430 020456 0ustar00johnstaff000000 000000 --- abstract: 'An enhanced populate method' author: - 'John Napiorkowski, C<< >>' build_requires: DBIx::Class: '0.08127' DateTime::Format::SQLite: '0.11' ExtUtils::MakeMaker: 6.59 File::Find: 0 Path::Class: '0.23' SQL::Translator: '0.11020' Test::More: '0.98' YAML::Tiny: '1.48' configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.12' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 module_name: DBIx::Class::Schema::PopulateMore name: DBIx-Class-Schema-PopulateMore no_index: directory: - inc - t requires: DateTimeX::Easy: '0.089' List::MoreUtils: '0.30' Module::Pluggable: '3.9' Moo: '1.004006' MooX::HandlesVia: '0.001005' Scalar::Util: '1.35' Type::Tiny: '0.042' parent: '0.224' perl: 5.8.5 resources: homepage: http://search.cpan.org/dist/DBIx-Class-Schema-PopulateMore/ license: http://dev.perl.org/licenses/ repository: git://github.com/jjn1056/DBIx-Class-Schema-PopulateMore.git version: '0.19' DBIx-Class-Schema-PopulateMore-0.19/README.mkdn000644 000766 000024 00000024021 12415571430 021017 0ustar00johnstaff000000 000000 # NAME DBIx::Class::Schema::PopulateMore - An enhanced populate method # VERSION Version 0.19 # SYNOPSIS The following is example usage for this component. package Myapp::Schema; use base qw/DBIx::Class::Schema/; __PACKAGE__->load_components(qw/Schema::PopulateMore/); __PACKAGE__->load_namespaces(); ## All the rest of your setup Then assuming you have ResultSources of Gender, Person and FriendList: my $setup_rows = [ {Gender => { fields => 'label', data => { male => 'male', female => 'female', }}}, {Person => { fields => ['name', 'age', 'gender'], data => { john => ['john', 38, "!Index:Gender.male"], jane => ['jane', 40, '!Index:Gender.female'], }}}, {FriendList => { fields => ['person', 'friend', 'created_date'], data => { john_jane => [ '!Index:Person.john', '!Index:Person.jane' '!Date: March 30, 1996', ], }}}, ]; $schema->populate_more($setup_rows); Please see the test cases for more detailed examples. # DESCRIPTION This is a [DBIx::Class::Schema](https://metacpan.org/pod/DBIx::Class::Schema) component that provides an enhanced version of the builtin method ["populate" in DBIx::Class::Schema](https://metacpan.org/pod/DBIx::Class::Schema#populate). What it does is make it easier when you are doing a first time setup and need to insert a bunch of rows, like the first time you deploy a new database, or after you update it. It's not as full featured as [DBIx::Class::Fixtures](https://metacpan.org/pod/DBIx::Class::Fixtures) but is targeted more directly at making it easier to just take a prewritten perl structure --or one loaded from a configuration file-- and setup your database. Most of us using [DBIx::CLass](https://metacpan.org/pod/DBIx::CLass) have written a version of this at one time or another. What is special to this component is the fact that unlike the normal populate method you can insert to multiple result\_sources in one go. While doing this, we index the created rows so as to make it easy to reference them in relationships. I did this because I think it's very ugly to have to type in all the primary keys by hand, particularly if your PK is multi column, or is using some lengthy format such as uuid. Also, we can embed expansion commands in the row values to do inflation for us. For example, any value starting with "!Index:" will substitute it's value for that of the relating fields in the named row. This distribution supplies three expansion commands: - Index Use for creating relationships. This is a string in the form of "Source.Label" where the Source is the name of the result source that you are creating rows in and Label is a key name from the key part of the data hash. - Env Get's it's value from %ENV. Typically this will be setup in your shell or at application runtime. This is a string in the form of "!Env:MY\_ENV\_VAR" - Date converts it's value to a [DateTime](https://metacpan.org/pod/DateTime) object. Will use a various methods to try and coerce a string, like "today", or "January 6, 1974". Makes it easier to insert dates into your database without knowing or caring about the expected format. For this to work correctly, you need to use the class component [DBIx::Class::InflateColumn::DateTime](https://metacpan.org/pod/DBIx::Class::InflateColumn::DateTime) and mark your column data type as 'datetime' or similar. - Find Used for when you want the value of something that you expect already exists in the database (but for which you didn't just populatemore for, use 'Index' for that case.) Use cases for this include lookup style tables, like 'Status' or 'Gender', 'State', etc. which you may already have installed. This is a string in the form of '!Find:Source.\[key1=val1,key2=val2,...'. If your find doesn't return a single result, expect an error. It's trivial to write more; please feel free to post me your contributions. Please note the when inserting rows, we are actually calling "create\_or\_update" on each data item, so this will not be as fast as using $schema->bulk\_insert. # METHODS This module defines the following methods. ## populate\_more ($ArrayRef||@Array) Given an arrayref formatted as in the ["SYNOPSIS"](#synopsis) example, populate a rows in a database. Confesses on errors. We allow a few different inputs to make it less verbose to use under different situations, as well as format nicely using your configuration format of choice. The $ArrayRef contains one or more elements in the following pattern; $schema->populate_more([ {Source1 => { fields => [qw/ column belongs_to has_many/], data => { key_1 => ['value', $row, \@rows ], }}}, {Source2 => { fields => [qw/ column belongs_to has_many/], data => { key_1 => ['value', $row, \@rows ], }}}, ]); The @Array version can be one of the following: ## Option One $schema->populate_more( {Source1 => { fields => [qw/ column belongs_to has_many/], data => { key_1 => ['value', $row, \@rows ], }}}, {Source2 => { fields => [qw/ column belongs_to has_many/], data => { key_1 => ['value', $row, \@rows ], }}}, ); ## Option Two $schema->populate_more( Source1 => { fields => [qw/ column belongs_to has_many/], data => { key_1 => ['value', $row, \@rows ], } }, Source2 => { fields => [qw/ column belongs_to has_many/], data => { key_1 => ['value', $row, \@rows ], } }, ); The last option is probably your choice if you are building a Perl structure directly, since it's the least verbose. 'SourceX' is the name of a DBIC source (as in $schema->resultset($Source)->...) while fields is an arrayref of either columns or named relationships and data is a hashref of rows that you will insert into the Source. See ["SYNOPSIS"](#synopsis) for more. # ARGUMENT NOTES The perl structure used in ["populate\_more"](#populate_more) was designed to be reasonable friendly to type in most of the popular configuration formats. For example, the above serialized to YAML would look like: - Gender: fields: label data: female: female male: male - Person: fields: - name - age - gender data: jane: - jane - 40 - '!Index:Gender.female' john: - john - 38 - !Index:Gender.male' - FriendList: fields: - person - friend - created_date data: john_jane: - '!Index:Person.john' - '!Index:Person.jane' - '!Date: March 30, 1996' Since the argument is an arrayref or an array, the same base result source can appear as many times as you like. This could be useful when a second insert to a given source requires completion of other inserts. The insert order follows the index of the arrayref you create. # AUTHOR John Napiorkowski, `` # BUGS Please report any bugs or feature requests to: C or through the web interface at: L I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. # SUPPORT You can find documentation for this module with the perldoc command. perldoc DBIx::Class::Schema::PopulateMore You can also look for information at: - RT: CPAN's request tracker [http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBIx-Class-Schema-PopulateMore](http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBIx-Class-Schema-PopulateMore) - AnnoCPAN: Annotated CPAN documentation [http://annocpan.org/dist/DBIx-Class-Schema-PopulateMore](http://annocpan.org/dist/DBIx-Class-Schema-PopulateMore) - CPAN Ratings [http://cpanratings.perl.org/d/DBIx-Class-Schema-PopulateMore](http://cpanratings.perl.org/d/DBIx-Class-Schema-PopulateMore) - Search CPAN [http://search.cpan.org/dist/DBIx-Class-Schema-PopulateMore](http://search.cpan.org/dist/DBIx-Class-Schema-PopulateMore) # ACKNOWLEDGEMENTS Thanks to the entire [DBIx::Class](https://metacpan.org/pod/DBIx::Class) team for providing such a useful and extensible ORM. Also thanks to the [Moose](https://metacpan.org/pod/Moose) developers for making it fun and easy to write beautiful Perl. # COPYRIGHT & LICENSE Copyright 2011, John Napiorkowski This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. DBIx-Class-Schema-PopulateMore-0.19/t/000755 000766 000024 00000000000 12415571446 017462 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/t/00-load.t000644 000766 000024 00000002433 12415565435 021006 0ustar00johnstaff000000 000000 use warnings; use strict; use DBIx::Class::Schema::PopulateMore; use Test::More tests => 16; diag( "Testing DBIx::Class::Schema::PopulateMore $DBIx::Class::Schema::PopulateMore::VERSION, Perl $], $^X" ); use_ok( 'DBIx::Class::Schema::PopulateMore' ); use_ok( 'DBIx::Class::Schema::PopulateMore::Command' ); use_ok( 'DBIx::Class::Schema::PopulateMore::Inflator' ); use_ok( 'DBIx::Class::Schema::PopulateMore::Visitor' ); use_ok( 'DBIx::Class::Schema::PopulateMore::Inflator::Index' ); use_ok( 'DBIx::Class::Schema::PopulateMore::Inflator::Date' ); use_ok( 'DBIx::Class::Schema::PopulateMore::Inflator::Env' ); use_ok( 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result' ); use_ok( 'DBIx::Class::Schema::PopulateMore::Test::Schema::ResultSet' ); use_ok( 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result::Gender' ); use_ok( 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result::Person' ); use_ok( 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result::FriendList' ); use_ok( 'DBIx::Class::Schema::PopulateMore::Test::Schema::ResultSet::Person' ); use_ok( 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result::Company' ); use_ok( 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result::CompanyPerson' ); use_ok( 'DBIx::Class::Schema::PopulateMore::Test::Schema' ); DBIx-Class-Schema-PopulateMore-0.19/t/01-schema.t000644 000766 000024 00000013744 12415565435 021337 0ustar00johnstaff000000 000000 use warnings; use strict; use Test::More tests => 43; use DBIx::Class::Schema::PopulateMore::Test::Schema; ok my $schema = DBIx::Class::Schema::PopulateMore::Test::Schema->connect_and_setup => 'Got a schema'; diag "Created Datebase with @{$schema->storage->connect_info}[0]"; ok $schema->can('populate_more') => 'schema has required method'; ok my @sources = sort($schema->sources) => 'got some sources'; is_deeply \@sources, [qw/ Company CompanyPerson EmploymentHistory FriendList Gender Person/] => 'Got expected sources'; ok my $populate = [ {Gender => { fields => 'label', data => { male => 'male', female => 'female', }}}, {Person => { fields => ['name', 'age', 'gender'], data => { john => ['john', 38, "!Index:Gender.male"], jane => ['jane', 40, '!Index:Gender.female'], }}}, {Company => { fields => ['name', 'company_persons'], data => { bms => ['bristol meyers squibb', [ {employee=>'!Index:Person.john'}, {employee=>'!Index:Person.jane'}, ]], takkle => ['takkle', [ { employee => '!Index:Person.john', employment_history => { started=>'!Date:january 1, 2000', } }, ]], }}}, {FriendList => { fields => ['befriender', 'friendee'], data => { john_jane => ['!Index:Person.john', '!Index:Person.jane'], }}}, {Person => { fields => ['name', 'age', 'gender', 'friendlist'], data => { mike => ['mike', 25, "!Index:Gender.male", [ {friendee=>'!Index:Person.john'}, {friendee=>'!Index:Person.jane'}, ]], }}}, {CompanyPerson => { fields => ['employee', 'company', 'employment_history'], data => { mike_at_takkle => [ '!Index:Person.mike', '!Index:Company.takkle', {started=>'!Date:yesterday'} ], }}}, ] => 'Create structure to populate_more with'; ok my %index = $schema->populate_more($populate) => 'Successful populated.'; ## Find some Genders GENDER: { ok my $gender_rs = $schema->resultset('Gender') => 'Got a resultset of genders'; is $gender_rs->count, 2 => 'Got expected number of genders'; ok $gender_rs->find({label=>'male'}) => 'Found male'; ok $gender_rs->find({label=>'female'}) => 'Found female'; ok ! $gender_rs->find({label=>'transgender'}) => 'Correctly didn not find transgender'; } ## Find some People PERSON: { ok my $person_rs = $schema->resultset('Person') => 'Got a person resultset'; is $person_rs->count, 3 => 'Got expected number of person_rs'; ok my $john = $person_rs->search({name=>'john'})->first => 'Found John'; is $john->age, 38 => 'Got correct age for john'; ok my $jane = $person_rs->search({name=>'jane'})->first => 'Found John'; is $jane->age, 40 => 'Got correct age for jane'; } ## Find some companies COMPANY: { ok my $company_rs = $schema->resultset('Company') => 'Got a person resultset'; is $company_rs->count, 2 => 'Got expected number of person_rs'; ok my $takkle = $company_rs->search({name=>'takkle'})->first => 'Found takkle'; ok my $company_persons_rs = $takkle->company_persons => 'got company_persons'; is $company_persons_rs->count, 2 => 'got right number of $company_persons_rs'; ok my $employees_rs = $takkle->employees => 'got some employees'; ok my $john = $employees_rs->search({name=>'john'})->first => 'found john'; is $john->age, 38 => 'got correct age'; ok my $bms = $company_rs->search({name=>'bristol meyers squibb'})->first => 'Found bristol meyers squibb'; is $bms->employees->count, 2 => 'got correct count for bms employees'; } ## Test Friendlist FRIENDLIST: { ok my $friendlist_rs = $schema->resultset('FriendList') => 'Got a friendlist resultset'; is $friendlist_rs->count, 3 => 'Got expected number of friendlist_rs'; ok my $mike = $schema->resultset('Person')->search({name=>'mike'})->first => 'found mike'; is $mike->friends, 2 => 'got correct number of friends for mike'; } ## Extra tests for alternative ->populate_more argument styles ok my $extra = [ {Person => { fields => ['name', 'age', 'gender'], data => { joe => ['joe', 19, '!Find:Gender.[label=male]'], }}}, ], 'Created extra'; ok my %index2 = $schema->populate_more($extra) => 'Successful populated again.'; ok my $joe = $schema->resultset('Person')->search({name=>'joe'})->first, => 'Got a Person'; is $joe->age, 19, 'Joe is 19'; ok $joe->delete, 'Delete Joe'; ok my %index2_again = $schema->populate_more($extra) => 'Successful populated same data again.'; ok my $joe_again = $schema->resultset('Person')->search({name=>'joe'})->first, => 'Got a Person again'; ok my %index3 = $schema->populate_more( Gender => { fields => 'label', data => { unknown => 'unknown', } }, Person => { fields => ['name', 'age', 'gender'], data => { toad => ['toad', 38, '!Index:Gender.unknown'], bill => ['bill', 40, '!Find:Gender.[label=male]'], york => ['york', 45, '!Find:Gender.[label=female]'], } }, ) => 'Successful populated.'; ok my ($bill,$toad,$york) = $schema->resultset('Person')->search({name=>[qw/bill toad york/]},{order_by=>\"name asc"}) => 'Found bill, toad and york'; is $bill->age, 40, 'Got correct age for bill'; is $toad->age, 38, 'Got correct age for toad'; is $york->age, 45, 'Got correct age for york'; DBIx-Class-Schema-PopulateMore-0.19/t/02-yaml_example.t000644 000766 000024 00000010511 12415565435 022542 0ustar00johnstaff000000 000000 use warnings; use strict; use Test::More tests => 31; use DBIx::Class::Schema::PopulateMore::Test::Schema; use YAML::Tiny; ## This is just a quick example to show what this might look like if you ## loaded from an external file, like yaml. It's evil cut 'n paste from ## the standard test. ok my $schema = DBIx::Class::Schema::PopulateMore::Test::Schema->connect_and_setup => 'Got a schema'; diag "Created Datebase with @{$schema->storage->connect_info}[0]"; ok $schema->can('populate_more') => 'schema has required method'; ok my @sources = sort($schema->sources) => 'got some sources'; is_deeply \@sources, [qw/ Company CompanyPerson EmploymentHistory FriendList Gender Person/] => 'Got expected sources'; my $string = join('', ); ok my $yaml = YAML::Tiny->read_string( $string ) => 'loaded yaml config'; ok my %index = $schema->populate_more($yaml->[0]) => 'Successful populated.'; ## Find some Genders GENDER: { ok my $gender_rs = $schema->resultset('Gender') => 'Got a resultset of genders'; is $gender_rs->count, 2 => 'Got expected number of genders'; ok $gender_rs->find({label=>'male'}) => 'Found male'; ok $gender_rs->find({label=>'female'}) => 'Found female'; ok ! $gender_rs->find({label=>'transgender'}) => 'Correctly didn not find transgender'; } ## Find some People PERSON: { ok my $person_rs = $schema->resultset('Person') => 'Got a person resultset'; is $person_rs->count, 3 => 'Got expected number of person_rs'; ok my $john = $person_rs->search({name=>'john'})->first => 'Found John'; is $john->age, 38 => 'Got correct age for john'; ok my $jane = $person_rs->search({name=>'jane'})->first => 'Found John'; is $jane->age, 40 => 'Got correct age for jane'; } ## Find some companies COMPANY: { ok my $company_rs = $schema->resultset('Company') => 'Got a person resultset'; is $company_rs->count, 2 => 'Got expected number of person_rs'; ok my $takkle = $company_rs->search({name=>'takkle'})->first => 'Found takkle'; ok my $company_persons_rs = $takkle->company_persons => 'got company_persons'; is $company_persons_rs->count, 2 => 'got right number of $company_persons_rs'; ok my $employees_rs = $takkle->employees => 'got some employees'; ok my $john1 = $employees_rs->search({name=>'john'})->first => 'found john'; is $john1->age, 38 => 'got correct age'; ok my $bms = $company_rs->search({name=>'bristol meyers squibb'})->first => 'Found bristol meyers squibb'; is $bms->employees->count, 2 => 'got correct count for bms employees'; } ## Test Friendlist FRIENDLIST: { ok my $friendlist_rs = $schema->resultset('FriendList') => 'Got a friendlist resultset'; is $friendlist_rs->count, 3 => 'Got expected number of friendlist_rs'; ok my $mike = $schema->resultset('Person')->search({name=>'mike'})->first => 'found mike'; is $mike->friends, 2 => 'got correct number of friends for mike'; } __DATA__ --- - Gender: data: female: female male: male fields: label - Person: data: jane: - jane - 40 - '!Index:Gender.female' john: - john - 38 - '!Index:Gender.male' fields: - name - age - gender - Company: data: bms: - bristol meyers squibb - - employee: '!Index:Person.john' - employee: '!Index:Person.jane' takkle: - takkle - - employee: '!Index:Person.john' employment_history: started: '!Date:january 1, 2000' fields: - name - company_persons - FriendList: data: john_jane: - '!Index:Person.john' - '!Index:Person.jane' fields: - befriender - friendee - Person: data: mike: - mike - 25 - '!Index:Gender.male' - - friendee: '!Index:Person.john' - friendee: '!Index:Person.jane' fields: - name - age - gender - friendlist - CompanyPerson: data: mike_at_takkle: - '!Index:Person.mike' - '!Index:Company.takkle' - started: '!Date:yesterday' fields: - employee - company - employment_history DBIx-Class-Schema-PopulateMore-0.19/t/author/000755 000766 000024 00000000000 12415571446 020764 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/t/var/000755 000766 000024 00000000000 12415571446 020252 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/t/var/README000644 000766 000024 00000000127 12415565435 021133 0ustar00johnstaff000000 000000 This directory needs to exists to run all the database tests. Please don't delete it! DBIx-Class-Schema-PopulateMore-0.19/t/author/newlines.t000644 000766 000024 00000003435 12415565435 023003 0ustar00johnstaff000000 000000 use strict; use warnings; BEGIN { use Test::More; use File::Find; # Are we an author test? plan skip_all => 'Skipping author tests' unless $ENV{RUN_AUTHOR_TESTS}; } my @files; find({ wanted => \&process, follow => 0 }, '.'); sub process { my $file = $_; return if $File::Find::dir =~m/\.svn/; return if $File::Find::dir =~m/archive/; push @files, $File::Find::name if $file =~m/\.yml$|\.pm$|\.pod$|\.tt$|\.txt$|\.js$|\.css$|\.sql$|\.html$/; } my $CR = "\015"; # Apple II family, Mac OS thru version 9 my $CRLF = "\015\012"; # CP/M, MP/M, DOS, Microsoft Windows my $FF = "\014"; # printer form feed my $LF = "\012"; # Unix, Linux, Xenix, Mac OS X, BeOS, Amiga my $test_builder = Test::More->builder; if( $#files ) { $test_builder->plan(tests => ($#files+1)*2); foreach my $file (@files) { ## Get a good filehandle open( my $fh, '<', $file) or fail "Can't open $file, can't finish testing"; ## Only need to test the first line. my ($first, $second) = <$fh>; ## Don't need this anymore close($fh); SKIP: { skip "$file is Empty!", 2 unless $first; ## Are we DOS or MACOS/APPLE? ok $first!~m/$CRLF$|$CR$|$FF$/, "$file isn't in a forbidden format"; ## If there is more than one line, we HAVE to be UNIX SKIP: { skip "$file only has a single line", 1 unless $second; ok $first=~m/$LF$/, "$file Is unix linefeed"; } } } } else { $test_builder->plan(skip_all => 'No Text Files Found! (This is probably BIG Trouble...'); } 1; DBIx-Class-Schema-PopulateMore-0.19/t/author/pod-coverage.t000644 000766 000024 00000001213 12415565435 023522 0ustar00johnstaff000000 000000 use strict; use warnings; use Test::More; # Are we an author test? plan skip_all => 'Skipping author tests' unless $ENV{RUN_AUTHOR_TESTS}; # Ensure a recent version of Test::Pod::Coverage my $min_tpc = 1.08; eval "use Test::Pod::Coverage $min_tpc"; plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, # but older versions don't recognize some common documentation styles my $min_pc = 0.18; eval "use Pod::Coverage $min_pc"; plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; all_pod_coverage_ok(); DBIx-Class-Schema-PopulateMore-0.19/t/author/pod.t000644 000766 000024 00000000513 12415565435 021733 0ustar00johnstaff000000 000000 #!perl -T use strict; use warnings; use Test::More; # Are we an author test? plan skip_all => 'Skipping author tests' unless $ENV{RUN_AUTHOR_TESTS}; # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok(); DBIx-Class-Schema-PopulateMore-0.19/maint/Makefile.PL.include000644 000766 000024 00000002075 12415565435 023730 0ustar00johnstaff000000 000000 BEGIN { my @modules = qw( ReadmeMarkdownFromPod ManifestSkip AutoLicense Repository Homepage AutoManifest ); for my $module (@modules) { eval "use Module::Install::$module; 1" || die <<"ERR"; You are in author mode but are missing Module::Install::$module You are getting an error message because you are in author mode and are missing some author only dependencies. You should only see this message if you have checked this code out from a repository. If you are just trying to install the code please use the CPAN version. If you are an author you will need to install the missing modules, or you can bootstrap all the requirements using Task::BeLike::JJNAPIORK with: cpanm Task::BeLike::JJNAPIORK If you think you are seeing this this message in error, please report it as a bug to the author. ERR } } readme_markdown_from_pod; manifest_skip; auto_license; auto_set_repository; auto_set_homepage; auto_manifest; auto_install; postamble <<"EOP"; distclean :: manifest_skip_clean manifest_skip_clean: \t\$(RM_F) MANIFEST.SKIP EOP DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/000755 000766 000024 00000000000 12415571446 020553 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/000755 000766 000024 00000000000 12415571446 021620 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/000755 000766 000024 00000000000 12415571446 023020 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/000755 000766 000024 00000000000 12415571446 025434 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore.pm000644 000766 000024 00000021131 12415565653 025773 0ustar00johnstaff000000 000000 package DBIx::Class::Schema::PopulateMore; use warnings; use strict; use 5.008005; use DBIx::Class::Schema::PopulateMore::Command; =head1 NAME DBIx::Class::Schema::PopulateMore - An enhanced populate method =head1 VERSION Version 0.19 =cut our $VERSION = '0.19'; =head1 SYNOPSIS The following is example usage for this component. package Myapp::Schema; use base qw/DBIx::Class::Schema/; __PACKAGE__->load_components(qw/Schema::PopulateMore/); __PACKAGE__->load_namespaces(); ## All the rest of your setup Then assuming you have ResultSources of Gender, Person and FriendList: my $setup_rows = [ {Gender => { fields => 'label', data => { male => 'male', female => 'female', }}}, {Person => { fields => ['name', 'age', 'gender'], data => { john => ['john', 38, "!Index:Gender.male"], jane => ['jane', 40, '!Index:Gender.female'], }}}, {FriendList => { fields => ['person', 'friend', 'created_date'], data => { john_jane => [ '!Index:Person.john', '!Index:Person.jane' '!Date: March 30, 1996', ], }}}, ]; $schema->populate_more($setup_rows); Please see the test cases for more detailed examples. =head1 DESCRIPTION This is a L component that provides an enhanced version of the builtin method L. What it does is make it easier when you are doing a first time setup and need to insert a bunch of rows, like the first time you deploy a new database, or after you update it. It's not as full featured as L but is targeted more directly at making it easier to just take a prewritten perl structure --or one loaded from a configuration file-- and setup your database. Most of us using L have written a version of this at one time or another. What is special to this component is the fact that unlike the normal populate method you can insert to multiple result_sources in one go. While doing this, we index the created rows so as to make it easy to reference them in relationships. I did this because I think it's very ugly to have to type in all the primary keys by hand, particularly if your PK is multi column, or is using some lengthy format such as uuid. Also, we can embed expansion commands in the row values to do inflation for us. For example, any value starting with "!Index:" will substitute it's value for that of the relating fields in the named row. This distribution supplies three expansion commands: =over 4 =item Index Use for creating relationships. This is a string in the form of "Source.Label" where the Source is the name of the result source that you are creating rows in and Label is a key name from the key part of the data hash. =item Env Get's it's value from %ENV. Typically this will be setup in your shell or at application runtime. This is a string in the form of "!Env:MY_ENV_VAR" =item Date converts it's value to a L object. Will use a various methods to try and coerce a string, like "today", or "January 6, 1974". Makes it easier to insert dates into your database without knowing or caring about the expected format. For this to work correctly, you need to use the class component L and mark your column data type as 'datetime' or similar. =item Find Used for when you want the value of something that you expect already exists in the database (but for which you didn't just populatemore for, use 'Index' for that case.) Use cases for this include lookup style tables, like 'Status' or 'Gender', 'State', etc. which you may already have installed. This is a string in the form of '!Find:Source.[key1=val1,key2=val2,...'. If your find doesn't return a single result, expect an error. It's trivial to write more; please feel free to post me your contributions. =back Please note the when inserting rows, we are actually calling "create_or_update" on each data item, so this will not be as fast as using $schema->bulk_insert. =head1 METHODS This module defines the following methods. =head2 populate_more ($ArrayRef||@Array) Given an arrayref formatted as in the L example, populate a rows in a database. Confesses on errors. We allow a few different inputs to make it less verbose to use under different situations, as well as format nicely using your configuration format of choice. The $ArrayRef contains one or more elements in the following pattern; $schema->populate_more([ {Source1 => { fields => [qw/ column belongs_to has_many/], data => { key_1 => ['value', $row, \@rows ], }}}, {Source2 => { fields => [qw/ column belongs_to has_many/], data => { key_1 => ['value', $row, \@rows ], }}}, ]); The @Array version can be one of the following: ## Option One $schema->populate_more( {Source1 => { fields => [qw/ column belongs_to has_many/], data => { key_1 => ['value', $row, \@rows ], }}}, {Source2 => { fields => [qw/ column belongs_to has_many/], data => { key_1 => ['value', $row, \@rows ], }}}, ); ## Option Two $schema->populate_more( Source1 => { fields => [qw/ column belongs_to has_many/], data => { key_1 => ['value', $row, \@rows ], } }, Source2 => { fields => [qw/ column belongs_to has_many/], data => { key_1 => ['value', $row, \@rows ], } }, ); The last option is probably your choice if you are building a Perl structure directly, since it's the least verbose. 'SourceX' is the name of a DBIC source (as in $schema->resultset($Source)->...) while fields is an arrayref of either columns or named relationships and data is a hashref of rows that you will insert into the Source. See L for more. =cut sub populate_more { my ($self, $arg, @rest) = @_; $self->throw_exception("Argument is required.") unless $arg; my @args = (ref $arg && ref $arg eq 'ARRAY') ? @$arg : ($arg, @rest); my @definitions; while(@args) { my $next = shift(@args); if( (ref $next) && (ref $next eq 'HASH') ) { push @definitions, $next; } else { my $value = shift(@args); push @definitions, {$next => $value}; } } my $command; eval { $command = DBIx::Class::Schema::PopulateMore::Command->new( definitions=>[@definitions], schema=>$self, exception_cb=>sub { $self->throw_exception(@_); }, ); }; if($@) { $self->throw_exception("Can't create Command: $@"); } else { $command->execute; } } =head1 ARGUMENT NOTES The perl structure used in L was designed to be reasonable friendly to type in most of the popular configuration formats. For example, the above serialized to YAML would look like: - Gender: fields: label data: female: female male: male - Person: fields: - name - age - gender data: jane: - jane - 40 - '!Index:Gender.female' john: - john - 38 - !Index:Gender.male' - FriendList: fields: - person - friend - created_date data: john_jane: - '!Index:Person.john' - '!Index:Person.jane' - '!Date: March 30, 1996' Since the argument is an arrayref or an array, the same base result source can appear as many times as you like. This could be useful when a second insert to a given source requires completion of other inserts. The insert order follows the index of the arrayref you create. =head1 AUTHOR John Napiorkowski, C<< >> =head1 BUGS Please report any bugs or feature requests to: C or through the web interface at: L I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc DBIx::Class::Schema::PopulateMore You can also look for information at: =over 4 =item * RT: CPAN's request tracker L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =back =head1 ACKNOWLEDGEMENTS Thanks to the entire L team for providing such a useful and extensible ORM. Also thanks to the L developers for making it fun and easy to write beautiful Perl. =head1 COPYRIGHT & LICENSE Copyright 2011, John Napiorkowski This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/Command.pm000644 000766 000024 00000015446 12415565435 027363 0ustar00johnstaff000000 000000 package DBIx::Class::Schema::PopulateMore::Command; use Moo; use MooX::HandlesVia; use List::MoreUtils qw(pairwise); use DBIx::Class::Schema::PopulateMore::Visitor; use Module::Pluggable::Object; use Type::Library -base; use Types::Standard -types; use namespace::clean; =head1 NAME DBIx::Class::Schema::PopulateMore::Command - Command Class to Populate a Schema =head1 DESCRIPTION This is a command pattern class to manage the job of populating a L with information. We break this out because the actual job is a bit complex, is likely to grow more complex, and so that we can more easily identify refactorable and reusable parts. =head1 ATTRIBUTES This class defines the following attributes. =head2 schema This is the Schema we are populating =cut has schema => ( is=>'ro', required=>1, isa=>Object, ); =head2 exception_cb contains a callback to the exception method supplied by DBIC =cut has exception_cb => ( is=>'ro', required=>1, isa=>CodeRef, ); =head2 definitions This is an arrayref of information used to populate tables in the database =cut has definitions => ( is=>'ro', required=>1, isa=>ArrayRef[HashRef], ); =head2 match_condition How we know the value is really something to inflate or perform a substitution on. This get's the namespace of the substitution plugin and it's other data. =cut has match_condition => ( is=>'ro', required=>1, isa=>RegexpRef, default=>sub {qr/^!(\w+:.+)$/ }, ); =head2 visitor We define a visitor so that we can perform the value inflations and or substitutions. This is still a little work in progress, but it's getting neater =cut has visitor => ( is=>'lazy', isa=>InstanceOf['DBIx::Class::Schema::PopulateMore::Visitor'], handles => [ 'callback', 'visit', ], ); =head2 rs_index The index of previously inflated resultsets. Basically when we create a new row in the table, we cache the result object so that it can be used as a dependency in creating another. Eventually will be moved into the constructor for a plugin =head2 set_rs_index Set an index value to an inflated result =head2 get_rs_index given an index, returns the related inflated resultset =cut has rs_index => ( is=>'rw', handles_via=>'Hash', isa=>HashRef[Object], default=>sub { +{} }, handles=> { set_rs_index => 'set', get_rs_index => 'get', }, ); =head2 inflator_loader Loads each of the available inflators, provider access to the objects =cut has inflator_loader => ( is=>'lazy', isa=>InstanceOf['Module::Pluggable::Object'], handles=>{ 'inflators' => 'plugins', }, ); =head2 inflator_dispatcher Holds an object that can perform dispatching to the inflators. =cut has inflator_dispatcher => ( is=>'lazy', handles_via=>'Hash', isa=>HashRef[Object], handles=>{ inflator_list => 'keys', get_inflator => 'get', }, ); =head1 METHODS This module defines the following methods. =head2 _build_visitor lazy build for the L attribute. =cut sub _build_visitor { my $self = shift @_; DBIx::Class::Schema::PopulateMore::Visitor->new({ match_condition=>$self->match_condition }); } =head2 _build_inflator_loader lazy build for the L attribute =cut sub _build_inflator_loader { my $self = shift @_; return Module::Pluggable::Object->new( search_path => 'DBIx::Class::Schema::PopulateMore::Inflator', require => 1, except => 'DBIx::Class::Schema::PopulateMore::Inflator', ); } =head2 _build_inflator_dispatcher lazy build for the L attribute =cut sub _build_inflator_dispatcher { my $self = shift @_; my %inflators; for my $inflator ($self->inflators) { my $inflator_obj = $inflator->new; my $name = $inflator_obj->name; $inflators{$name} = $inflator_obj; } return \%inflators; } =head2 execute The command classes main method. Returns a Hash of the created result rows, where each key is the named index and the value is the row object. =cut sub execute { my ($self) = @_; foreach my $definition (@{$self->definitions}) { my ($source => $info) = %$definition; my @fields = $self->coerce_to_array($info->{fields}); my $data = $self ->callback(sub { $self->dispatch_inflator(shift); }) ->visit($info->{data}); while( my ($rs_key, $values) = each %{$data} ) { my @values = $self->coerce_to_array($values); my $new = $self->create_fixture( $rs_key => $source, $self->merge_fields_values([@fields], [@values]) ); } } return %{$self->rs_index}; } =head2 dispatch_inflator Dispatch to the correct inflator =cut sub dispatch_inflator { my ($self, $arg) = @_; my ($name, $command) = ($arg =~m/^(\w+):(\w.+)$/); if( my $inflator = $self->get_inflator($name) ) { $inflator->inflate($self, $command); } else { my $available = join(', ', $self->inflator_list); $self->exception_cb->("Can't Handle $name, available are: $available"); } } =head2 create_fixture({}) Given a hash suitable for a L create method, attempt to update or create a row in the named source. returns the newly created row or throws an exception if there is a failure =cut sub create_fixture { my ($self, $rs_key => $source, @create) = @_; my $new = $self ->schema ->resultset($source) ->update_or_create({@create}); $self->set_rs_index("$source.$rs_key" => $new); return $new; } =head2 merge_fields_values Given a fields and values, combine to a hash suitable for using in a create_fixture row statement. =cut sub merge_fields_values { my ($self, $fields, $values) = @_; return pairwise { $self->field_value($a,$b) } (@$fields, @$values); } =head2 field_value Correctly create an array from the fields, values variables, skipping those where the value is undefined. =cut sub field_value { my ($self, $a, $b) = @_; if(defined $a && defined $b) { return $a => $b; } else { return; } } =head2 coerce_to_array given a value that is either an arrayref or a scalar, put it into array context and return that array. =cut sub coerce_to_array { my ($self, $value) = @_; return ref $value eq 'ARRAY' ? @$value:($value); } =head1 AUTHOR Please see L For authorship information =head1 LICENSE Please see L For licensing terms. =cut 1; DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/Inflator/000755 000766 000024 00000000000 12415571446 027212 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/Inflator.pm000644 000766 000024 00000002712 12415565435 027553 0ustar00johnstaff000000 000000 package DBIx::Class::Schema::PopulateMore::Inflator; use Moo; =head1 NAME DBIx::Class::Schema::PopulateMore::Inflator - Base Class for keyword Inflators =head1 DESCRIPTION When L executes, it uses a visitor object (see L to descend the key values of the data hash that is used to put stuff into the given tables. If it finds a value that matches a particular regexp, that means the value needs to be inflated and it's passed to the inflating dispatcher, which finds the correct Inflator based on the given namespace. =head1 ATTRIBUTES This class defines the following attributes. =head1 METHODS This module defines the following methods. =head2 name returns the name of this inflator. Should be something you expect to be unique across all defined inflators. Defaults to something based on the namespace. =cut sub name { my $class = ref shift @_; my $package = __PACKAGE__; my ($name) = ($class =~m/^$package\:\:(.+)$/); return $name; } =head2 inflate($command, $string) This is called by L dispatcher, when there is a match detected by the visitor. =cut sub inflate { die "You forgot to implement ->inflate"; } =head1 AUTHOR Please see L For authorship information =head1 LICENSE Please see L For licensing terms. =cut 1; DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/Test/000755 000766 000024 00000000000 12415571446 026353 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/Visitor.pm000644 000766 000024 00000007374 12415565435 027445 0ustar00johnstaff000000 000000 package DBIx::Class::Schema::PopulateMore::Visitor; use Moo; use Scalar::Util qw/refaddr/; use Type::Library -base; use Types::Standard -types; use namespace::clean; =head1 NAME DBIx::Class::Schema::PopulateMore::Visitor - Visitor for the Populate Data =head1 SYNOPSIS ##Example Usage See Tests for more example usage. =head1 DESCRIPTION When populating a table, sometimes we need to inflate values that we won't know of in advance. For example we might have a column that is FK to another column in another table. We want to make it easy to 'tag' a value as something other than a real value to be inserted into the table. Right now we only have one substitution to do, which is the FK one mentioned above, but we might eventually create other substitution types so we've broken this out to make it neat and easy to do so. =head1 ATTRIBUTES This class defines the following attributes. =head2 update_callback The coderef to be execute should the match condition succeed =cut has 'update_callback' => ( is=>'rw', required=>1, lazy=>1, isa=>CodeRef, default=> sub { return sub { return shift; }; }, ); =head2 match_condition How we know the value is really something to inflate or perform a substitution on. This get's the namespace of the substitution plugin and it's other data. The default behavior (where there is no substitution namespace, is to do the inflate to resultset. This is the most common usecase. =cut has 'match_condition' => ( is=>'ro', required=>1, isa=>RegexpRef, ); =head2 seen Used to collect up ref addresses of arrays/hashes we have already seen =cut has seen => ( is => 'rw', isa => HashRef, default => sub { {} }, ); =head1 METHODS This module defines the following methods. =head2 callback Given a coderef, sets the current callback and returns self so that we can chain =cut sub callback { my $self = shift @_; $self->update_callback(shift @_); return $self; } =head2 visit A simple visitor that only expects to perform replacements on values =cut sub visit { my ( $self, $target ) = @_; if ( ref $target eq 'ARRAY' ) { my $addr = refaddr $target; return $self->seen->{$addr} if defined $self->seen->{$addr}; my $new_array = $self->seen->{$addr} = []; @$new_array = map { $self->visit($_) } @$target; return $new_array; } elsif ( ref $target eq 'HASH' ) { my $addr = refaddr $target; return $self->seen->{$addr} if defined $self->seen->{$addr}; my $new_hash = $self->seen->{$addr} = {}; %$new_hash = map { $_ => $self->visit( $target->{$_} ) } keys %$target; return $new_hash; } else { $self->visit_value($target); } } =head2 visit_value Here is where we make the choice as to if this value needs to be inflated via a plugin =cut sub visit_value { my ($self, $data) = @_; if(my $item = $self->match_or_not($data)) { return $self->update_callback->($item); } return $data; } =head2 match_or_not We break this out to handle the ugliness surrounding dealing with undef values and also to make it easier on subclassers. =cut sub match_or_not { my ($self, $data) = @_; my $match_condition = $self->match_condition; if( !defined $data ) { return; } elsif(my ($item) = ($data=~m/$match_condition/)) { return $item; } return; } =head1 AUTHOR Please see L For authorship information visit method culled from code in L which is copyright 2011 Daichi Hiroki =head1 LICENSE Please see L For licensing terms. =cut 1; DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/Test/Schema/000755 000766 000024 00000000000 12415571446 027553 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/Test/Schema.pm000644 000766 000024 00000003745 12415565435 030123 0ustar00johnstaff000000 000000 package # hide from PAUSE DBIx::Class::Schema::PopulateMore::Test::Schema; use Path::Class; use parent 'DBIx::Class::Schema'; =head1 NAME DBIx::Class::Schema::PopulateMore::Test::Schema; Test Schema =head1 DESCRIPTION Defines the base case for loading DBIC Schemas. This schema currently defines three sources, Person, FriendList, and Gender =head1 PACKAGE METHODS The following is a list of package methods declared with this class. =head2 load_components Load the components =cut __PACKAGE__->load_components(qw/ Schema::PopulateMore /); =head2 load_namespaces Automatically load the classes and resultsets from their default namespaces. =cut __PACKAGE__->load_namespaces( default_resultset_class => 'ResultSet', ); =head1 ATTRIBUTES This class defines the following attributes. =head1 METHODS This module declares the following methods =head2 connect_and_setup Creates a schema, deploys a database and sets the testing data. By default we use a L database created =cut sub connect_and_setup { my $class = shift @_; my ($dsn, $user, $pass) = ( $ENV{DBIC_POPULATE_DSN} || $class->default_dsn, $ENV{DBIC_POPULATE_USER} || '', $ENV{DBIC_POPULATE_PASS} || '', ); return $class ->connect($dsn, $user, $pass, { AutoCommit => 1 }) ->setup; } =head2 default_dsn returns a dsn string, suitable for passing to L, creating the database as a temporary file. =cut sub default_dsn { return "dbi:SQLite:dbname=:memory:"; } =head2 setup deploy a database and populate it with the initial data =cut sub setup { my $self = shift @_; $self->deploy(); return $self; } =head2 cleanup cleanup any temporary files =cut sub cleanup { my $self = shift @_; } sub DESTROY { (shift)->cleanup; } =head1 AUTHOR Please see L For authorship information =head1 LICENSE Please see L For licensing terms. =cut 1; DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/Test/Schema/Result/000755 000766 000024 00000000000 12415571446 031031 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/Test/Schema/Result.pm000644 000766 000024 00000001511 12415565435 031366 0ustar00johnstaff000000 000000 package # hide from PAUSE DBIx::Class::Schema::PopulateMore::Test::Schema::Result; use parent 'DBIx::Class::Core'; =head1 NAME DBIx::Class::Schema::PopulateMore::Test::Schema::Result - A base result class =head1 DESCRIPTION Defines the base case for loading DBIC Schemas. We add in some additional helpful functions for administering you schemas. =head1 PACKAGE METHODS The following is a list of package methods declared with this class. =head2 load_components Components to preload. =cut __PACKAGE__->load_components(qw/ PK::Auto InflateColumn::DateTime /); =head1 METHODS This module declares the following methods. =head1 AUTHOR Please see L For authorship information =head1 LICENSE Please see L For licensing terms. =cut 1; DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/Test/Schema/ResultSet/000755 000766 000024 00000000000 12415571446 031505 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/Test/Schema/ResultSet.pm000644 000766 000024 00000001546 12415565435 032052 0ustar00johnstaff000000 000000 package # hide from PAUSE DBIx::Class::Schema::PopulateMore::Test::Schema::ResultSet; use parent 'DBIx::Class::ResultSet'; =head1 NAME DBIx::Class::Schema::PopulateMore::Test::Schema::ResultSet - A base ResultSet Class =head1 DESCRIPTION All ResultSet classes will inherit from this. This provides some base function for all your resultsets and it is also the default resultset if you don't bother to declare a custom resultset in the resultset namespace =head1 PACKAGE METHODS The following is a list of package methods declared with this class. =head1 ATTRIBUTES This class defines the following attributes. =head1 METHODS This module declares the following methods =head1 AUTHOR Please see L For authorship information =head1 LICENSE Please see L For licensing terms. =cut 1; lib/DBIx/Class/Schema/PopulateMore/Test/Schema/ResultSet/Person.pm000644 000766 000024 00000001342 12415565435 033233 0ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19package #hide from pause DBIx::Class::Schema::PopulateMore::Test::Schema::ResultSet::Person; use parent 'DBIx::Class::Schema::PopulateMore::Test::Schema::ResultSet'; =head1 NAME DBIx::Class::Schema::PopulateMore::Test::Schema::ResultSet::Person - Person Resultset =head1 DESCRIPTION Resultset Methods for the Person Source =head1 METHODS This module defines the following methods. =head2 older_than($int) Only people over a given age =cut sub older_than { my ($self, $age) = @_; return $self->search({age=>{'>'=>$age}}); } =head1 AUTHOR Please see L For authorship information =head1 LICENSE Please see L For licensing terms. =cut 1; DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/Test/Schema/Result/Company.pm000644 000766 000024 00000003676 12415565435 033012 0ustar00johnstaff000000 000000 package #hide from pause DBIx::Class::Schema::PopulateMore::Test::Schema::Result::Company; use parent 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result'; =head1 NAME DBIx::Class::Schema::PopulateMore::Test::Schema::Result::Company - A Company Class =head1 DESCRIPTION Companies are entities people work for. A person can work for one or more companies. For the purposed of making this easy (for now) we will say that a company can exist without employees and that there is no logic preventing a person from working for more than one company at a time. =head1 PACKAGE METHODS This module defines the following package methods =head2 table Name of the Physical table in the database =cut __PACKAGE__ ->table('company'); =head2 add_columns Add columns and meta information =head3 company_id Primary Key which is an auto generated autoinc =head3 name The company's name =cut __PACKAGE__ ->add_columns( company_id => { data_type=>'integer', }, name => { data_type=>'varchar', size=>64, }); =head2 primary_key Sets the Primary keys for this table =cut __PACKAGE__ ->set_primary_key(qw/company_id/); =head2 company_persons Each Company might have a resultset from the company_person table. This is a bridge table in a many-many type relationship =cut __PACKAGE__ ->has_many( company_persons => 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result::CompanyPerson', {'foreign.fk_company_id' => 'self.company_id'}); =head2 employees A resultset of Persons via a resultset of connecting CompanyPersons =cut __PACKAGE__ ->many_to_many( employees => 'company_persons', 'employee' ); =head1 METHODS This module defines the following methods. =head1 AUTHOR Please see L For authorship information =head1 LICENSE Please see L For licensing terms. =cut 1; lib/DBIx/Class/Schema/PopulateMore/Test/Schema/Result/CompanyPerson.pm000644 000766 000024 00000004224 12415565435 034110 0ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19package #hide from pause DBIx::Class::Schema::PopulateMore::Test::Schema::Result::CompanyPerson; use parent 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result'; =head1 NAME DBIx::Class::Schema::PopulateMore::Test::Schema::Result::CompanyPerson - Bridge between Company and Person =head1 DESCRIPTION Bridge table for many to many style relationship between Company and Person. =head1 ATTRIBUTES This class defines the following attributes. =head1 PACKAGE METHODS This module defines the following package methods =head2 table Name of the Physical table in the database =cut __PACKAGE__ ->table('company_person'); =head2 add_columns Add columns and meta information =head3 fk_person_id ID of the person with a companies =head3 fk_company_id ID of the company with persons =cut __PACKAGE__ ->add_columns( fk_person_id => { data_type=>'integer', }, fk_company_id => { data_type=>'integer', }, ); =head2 primary_key Sets the Primary keys for this table =cut __PACKAGE__ ->set_primary_key(qw/fk_person_id fk_company_id/); =head2 employee The person that is employed by a company =cut __PACKAGE__ ->belongs_to( employee => 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result::Person', { 'foreign.person_id' => 'self.fk_person_id' }); =head2 company The company that employees the person =cut __PACKAGE__ ->belongs_to( company => 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result::Company', { 'foreign.company_id' => 'self.fk_company_id' }); =head2 employment_history each instance of a company_person has a related employment history =cut __PACKAGE__ ->has_one (employment_history => 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result::EmploymentHistory', { 'foreign.fk_company_id' => 'self.fk_company_id', 'foreign.fk_person_id' => 'self.fk_person_id', }); =head1 METHODS This module defines the following methods. =head1 AUTHOR Please see L For authorship information =head1 LICENSE Please see L For licensing terms. =cut 1; lib/DBIx/Class/Schema/PopulateMore/Test/Schema/Result/EmploymentHistory.pm000644 000766 000024 00000003640 12415565435 035027 0ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19package #hide from pause DBIx::Class::Schema::PopulateMore::Test::Schema::Result::EmploymentHistory; use parent 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result'; =head1 NAME DBIx::Class::Schema::PopulateMore::Test::Schema::Result::EmploymentHistory - Information about a Persons as an Employee; =head1 DESCRIPTION Additional Information about a person when working for a company =head1 ATTRIBUTES This class defines the following attributes. =head1 PACKAGE METHODS This module defines the following package methods =head2 table Name of the Physical table in the database =cut __PACKAGE__ ->table('employment_history'); =head2 add_columns Add columns and meta information =head3 fk_person_id, fk_company_id two fields making up a key to the CompanyPerson =head3 started The date we started working for the company =cut __PACKAGE__ ->add_columns( employment_history_id => { data_type=>'integer', }, fk_person_id => { data_type=>'integer', }, fk_company_id => { data_type=>'integer', }, started => { data_type=>'datetime', default_value=>\'CURRENT_TIMESTAMP', }); =head2 primary_key Sets the Primary keys for this table =cut __PACKAGE__ ->set_primary_key(qw/employment_history_id/); =head2 employment_history each instance of a company_person has a related employment history =cut __PACKAGE__ ->belongs_to (company_person => 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result::CompanyPerson', { 'foreign.fk_company_id' => 'self.fk_company_id', 'foreign.fk_person_id' => 'self.fk_person_id', }); =head1 METHODS This module defines the following methods. =head1 AUTHOR Please see L For authorship information =head1 LICENSE Please see L For licensing terms. =cut 1; lib/DBIx/Class/Schema/PopulateMore/Test/Schema/Result/FriendList.pm000644 000766 000024 00000003415 12415565435 033357 0ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19package #hide from pause DBIx::Class::Schema::PopulateMore::Test::Schema::Result::FriendList; use parent 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result'; =head1 NAME DBIx::Class::Schema::PopulateMore::Test::Schema::Result::FriendList - An example Friends Class; =head1 DESCRIPTION Probably not the best way to do a friend list relationship. =head1 ATTRIBUTES This class defines the following attributes. =head1 PACKAGE METHODS This module defines the following package methods =head2 table Name of the Physical table in the database =cut __PACKAGE__ ->table('friend_list'); =head2 add_columns Add columns and meta information =head3 fk_person_id ID of the person with friends =head3 fk_friend_id Who is the friend? =cut __PACKAGE__ ->add_columns( fk_person_id => { data_type=>'integer', }, fk_friend_id => { data_type=>'integer', }, ); =head2 primary_key Sets the Primary keys for this table =cut __PACKAGE__ ->set_primary_key(qw/fk_person_id fk_friend_id/); =head2 befriender The person that 'owns' the friendship (list) =cut __PACKAGE__ ->belongs_to( befriender => 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result::Person', { 'foreign.person_id' => 'self.fk_person_id' }); =head2 friendee The actual friend that befriender is listing =cut __PACKAGE__ ->belongs_to( friendee => 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result::Person', { 'foreign.person_id' => 'self.fk_friend_id' }); =head1 METHODS This module defines the following methods. =head1 AUTHOR Please see L For authorship information =head1 LICENSE Please see L For licensing terms. =cut 1; DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/Test/Schema/Result/Gender.pm000644 000766 000024 00000003134 12415565435 032575 0ustar00johnstaff000000 000000 package #hide from pause DBIx::Class::Schema::PopulateMore::Test::Schema::Result::Gender; use parent 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result'; =head1 NAME DBIx::Class::Schema::PopulateMore::Test::Schema::Result::Gender - A Gender Class =head1 DESCRIPTION Tests for this type of FK relationship =head1 PACKAGE METHODS This module defines the following package methods =head2 table Name of the Physical table in the database =cut __PACKAGE__ ->table('gender'); =head2 add_columns Add columns and meta information =head3 gender_id Primary Key which is an auto generated UUID =head3 label Text label of the gender (ie, 'male', 'female', 'transgender', etc.). =cut __PACKAGE__ ->add_columns( gender_id => { data_type=>'integer', }, label => { data_type=>'varchar', size=>12, }, ); =head2 primary_key Sets the Primary keys for this table =cut __PACKAGE__ ->set_primary_key(qw/gender_id/); =head2 Marks the unique columns =cut __PACKAGE__ ->add_unique_constraint('gender_label_unique' => [ qw/label/ ]); =head2 people A resultset of people with this gender =cut __PACKAGE__ ->has_many( people => 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result::Person', {'foreign.fk_gender_id' => 'self.gender_id'} ); =head1 METHODS This module defines the following methods. =head1 AUTHOR Please see L For authorship information =head1 LICENSE Please see L For licensing terms. =cut 1; DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/Test/Schema/Result/Person.pm000644 000766 000024 00000006167 12415565435 032650 0ustar00johnstaff000000 000000 package #hide from pause DBIx::Class::Schema::PopulateMore::Test::Schema::Result::Person; use parent 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result'; =head1 NAME DBIx::Class::Schema::PopulateMore::Test::Schema::Result::Person - A Person Class =head1 DESCRIPTION Tests for this type of FK relationship =head1 PACKAGE METHODS This module defines the following package methods =head2 table Name of the Physical table in the database =cut __PACKAGE__ ->table('person'); =head2 add_columns Add columns and meta information =head3 person_id Primary Key which is an auto generated autoinc =head3 fk_gender_id foreign key to the Gender table =head3 name Just an ordinary name =head3 age The person's age =head3 created When the person was added to the database =cut __PACKAGE__ ->add_columns( person_id => { data_type=>'integer', }, fk_gender_id => { data_type=>'integer', }, name => { data_type=>'varchar', size=>32, }, age => { data_type=>'integer', default_value=>25, }, created => { data_type=>'datetime', default_value=>\'CURRENT_TIMESTAMP', }); =head2 primary_key Sets the Primary keys for this table =cut __PACKAGE__ ->set_primary_key(qw/person_id/); =head2 friendlist Each Person might have a resultset of friendlist =cut __PACKAGE__ ->has_many( friendlist => 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result::FriendList', {'foreign.fk_person_id' => 'self.person_id'}); =head2 gender This person's gender =cut __PACKAGE__ ->belongs_to( gender => 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result::Gender', { 'foreign.gender_id' => 'self.fk_gender_id' }); =head2 fanlist A resultset of the people listing me as a friend (if any) =cut __PACKAGE__ ->belongs_to( fanlist => 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result::FriendList', { 'foreign.fk_friend_id' => 'self.person_id' }); =head2 friends A resultset of Persons who are in my FriendList =cut __PACKAGE__ ->many_to_many( friends => 'friendlist', 'friendee' ); =head2 fans A resultset of people that have me in their friendlist =cut __PACKAGE__ ->many_to_many( fans => 'fanlist', 'befriender' ); =head2 companies_person Each Person might have a resultset from the company_person table. This is a bridge table in a many-many type relationship =cut __PACKAGE__ ->has_many( companies_person => 'DBIx::Class::Schema::PopulateMore::Test::Schema::Result::CompanyPerson', {'foreign.fk_person_id' => 'self.person_id'}); =head2 companies A resultset of Companies via a resultset of connecting CompanyPersons =cut __PACKAGE__ ->many_to_many( companies => 'companies_person', 'company' ); =head1 METHODS This module defines the following methods. =head1 AUTHOR Please see L For authorship information =head1 LICENSE Please see L For licensing terms. =cut 1; DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/Inflator/Date.pm000644 000766 000024 00000002355 12415565435 030433 0ustar00johnstaff000000 000000 package DBIx::Class::Schema::PopulateMore::Inflator::Date; use Moo; use DateTimeX::Easy; extends 'DBIx::Class::Schema::PopulateMore::Inflator'; =head1 NAME DBIx::Class::Schema::PopulateMore::Inflator::Date - Returns A L object =head1 DESCRIPTION Sometimes you need to put dates into your table rows, but this can be a big hassle to do, particularly in a crossplatform way. This plugin will assist in this. It also makes it easy to insert relative date/times. such as 'now', 'last week', etc. See L for more information on how we coerce dates. =head1 ATTRIBUTES This class defines the following attributes. =head1 METHODS This module defines the following methods. =head2 inflate($command, $string) This is called by Populate's dispatcher, when there is a match. =cut sub inflate { my ($self, $command, $string) = @_; if(my $dt = DateTimeX::Easy->new($string, default_time_zone=>'UTC')) { return $dt; } else { $command->exception_cb->("Couldn't deal with $string as a date"); } } =head1 AUTHOR Please see L For authorship information =head1 LICENSE Please see L For licensing terms. =cut 1; DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/Inflator/Env.pm000644 000766 000024 00000002106 12415565435 030300 0ustar00johnstaff000000 000000 package DBIx::Class::Schema::PopulateMore::Inflator::Env; use Moo; extends 'DBIx::Class::Schema::PopulateMore::Inflator'; =head1 NAME DBIx::Class::Schema::PopulateMore::Inflator::Env - inflated via the %ENV hash =head1 DESCRIPTION So that a value in a fixture or populate can be set via %ENV. Checks the command and it's upcased version. =head1 ATTRIBUTES This class defines the following attributes. =head1 METHODS This module defines the following methods. =head2 inflate($command, $string) This is called by Populate's dispatcher, when there is a match. =cut sub inflate { my ($self, $command, $string) = @_; if( defined $ENV{$string} ) { return $ENV{$string}; } elsif( defined $ENV{uc $string} ) { return $ENV{uc $string}; } else { $command->exception_cb->("No match for $string found in %ENV"); } return; } =head1 AUTHOR Please see L For authorship information =head1 LICENSE Please see L For licensing terms. =cut 1; DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/Inflator/Find.pm000644 000766 000024 00000003131 12415565435 030427 0ustar00johnstaff000000 000000 package DBIx::Class::Schema::PopulateMore::Inflator::Find; use Moo; extends 'DBIx::Class::Schema::PopulateMore::Inflator'; =head1 NAME DBIx::Class::Schema::PopulateMore::Inflator::Find - Inflate via ResultSet->find =head1 SYNOPSIS !Find:Rating.10 => $schema->resultset('Rating')->find(10); !Find:Rating.[key=10] => $schema->resultset('Rating')->find(10); =head1 DESCRIPTION Given a Source.$value, do a $schema->Resultset('Source')->find($value) and use that value. We can't find anything, throw an exception. =head1 ATTRIBUTES This class defines the following attributes. =head1 METHODS This module defines the following methods. =head2 inflate($command, $string) This is called by Populate's dispatcher, when there is a match. =cut sub inflate { my ($self, $command, $string) = @_; my ($source, $id) = split('\.', $string); if(my $resultset = $command->schema->resultset($source)) { if($id =~m/^\[.+\]$/) { my ($pairs) = ($id=~m/^\[(.+)\]$/); my @pairs = split(',', $pairs); my %keys = map {split('=', $_) } @pairs; $id = \%keys; } if(my $result = $resultset->find($id)) { return $result; } else { $command->exception_cb->("Can't find result for '$id' in '$source'"); } } else { $command->exception_cb->("Can't find resultset for $source in $string"); } return; } =head1 AUTHOR Please see L For authorship information =head1 LICENSE Please see L For licensing terms. =cut 1; DBIx-Class-Schema-PopulateMore-0.19/lib/DBIx/Class/Schema/PopulateMore/Inflator/Index.pm000644 000766 000024 00000001625 12415565435 030624 0ustar00johnstaff000000 000000 package DBIx::Class::Schema::PopulateMore::Inflator::Index; use Moo; extends 'DBIx::Class::Schema::PopulateMore::Inflator'; =head1 NAME DBIx::Class::Schema::PopulateMore::Inflator::Index - Coerce DateTime from Strings =head1 DESCRIPTION Allows you to make the value equal to the result object of a previously inserted row. =head1 ATTRIBUTES This class defines the following attributes. =head1 METHODS This module defines the following methods. =head2 inflate($command, $string) This is called by Populate's dispatcher, when there is a match. =cut sub inflate { my ($self, $command, $string) = @_; return $command->get_rs_index($string) || $command->exception_cb->("Bad Index in Fixture: $string"); } =head1 AUTHOR Please see L For authorship information =head1 LICENSE Please see L For licensing terms. =cut 1; DBIx-Class-Schema-PopulateMore-0.19/inc/Module/000755 000766 000024 00000000000 12415571446 021215 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/inc/Pod/000755 000766 000024 00000000000 12415571446 020512 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/inc/Pod/Markdown.pm000644 000766 000024 00000054636 12415571427 022647 0ustar00johnstaff000000 000000 #line 1 # vim: set ts=2 sts=2 sw=2 expandtab smarttab: # # This file is part of Pod-Markdown # # This software is copyright (c) 2004 by Marcel Gruenauer. # # This is free software; you can redistribute it and/or modify it under # the same terms as the Perl 5 programming language system itself. # use 5.008; use strict; use warnings; package Pod::Markdown; # git description: v2.001-2-gadb8327 $Pod::Markdown::VERSION = '2.002'; BEGIN { $Pod::Markdown::AUTHORITY = 'cpan:RWSTAUNER'; } # ABSTRACT: Convert POD to Markdown use Pod::Simple 3.14 (); # external links with text use parent qw(Pod::Simple::Methody); our %URL_PREFIXES = ( sco => 'http://search.cpan.org/perldoc?', metacpan => 'https://metacpan.org/pod/', man => 'http://man.he.net/man', ); $URL_PREFIXES{perldoc} = $URL_PREFIXES{metacpan}; sub new { my $class = shift; my %args = @_; my $self = $class->SUPER::new(); $self->preserve_whitespace(1); $self->accept_targets(qw( markdown html )); my $data = $self->_private; while( my ($attr, $val) = each %args ){ $data->{ $attr } = $val; } for my $type ( qw( perldoc man ) ){ my $attr = $type . '_url_prefix'; # Use provided argument or default alias. my $url = $self->$attr || $type; # Expand alias if defined (otherwise use url as is). $data->{ $attr } = $URL_PREFIXES{ $url } || $url; } $self->_prepare_fragment_formats; return $self; } ## Attribute accessors ## my @attr = qw( man_url_prefix perldoc_url_prefix perldoc_fragment_format markdown_fragment_format include_meta_tags ); { no strict 'refs'; ## no critic foreach my $attr ( @attr ){ *$attr = sub { return $_[0]->_private->{ $attr } }; } } sub _prepare_fragment_formats { my ($self) = @_; foreach my $attr ( @attr ){ next unless $attr =~ /^(\w+)_fragment_format/; my $type = $1; my $format = $self->$attr; # If one was provided. if( $format ){ # If the attribute is a coderef just use it. next if ref($format) eq 'CODE'; } # Else determine a default. else { if( $type eq 'perldoc' ){ # Choose a default that matches the destination url. my $target = $self->perldoc_url_prefix; foreach my $alias ( qw( metacpan sco ) ){ if( $target eq $URL_PREFIXES{ $alias } ){ $format = $alias; } } # This seems like a reasonable fallback. $format ||= 'pod_simple_xhtml'; } else { $format = $type; } } # The short name should become a method name with the prefix prepended. my $prefix = 'format_fragment_'; $format =~ s/^$prefix//; die "Unknown fragment format '$format'" unless $self->can($prefix . $format); # Save it. $self->_private->{ $attr } = $format; } return; } ## Backward compatible API ## # For backward compatibility (previously based on Pod::Parser): # While Pod::Simple provides a parse_from_file() method # it's primarily for Pod::Parser compatibility. # When called without an output handle it will print to STDOUT # but the old Pod::Markdown never printed to a handle # so we don't want to start now. sub parse_from_file { my ($self, $file) = @_; $self->output_string(\($self->{_as_markdown_})); $self->parse_file($file); } # Likewise, though Pod::Simple doesn't define this method at all. sub parse_from_filehandle { shift->parse_from_file(@_) } ## Document state ## sub _private { my ($self) = @_; $self->{_Pod_Markdown_} ||= { indent => 0, stacks => [], states => [{}], link => [], }; } sub _increase_indent { ++$_[0]->_private->{indent} >= 1 or die 'Invalid state: indent < 0'; } sub _decrease_indent { --$_[0]->_private->{indent} >= 0 or die 'Invalid state: indent < 0'; } sub _new_stack { push @{ $_[0]->_private->{stacks} }, []; push @{ $_[0]->_private->{states} }, {}; } sub _last_string { $_[0]->_private->{stacks}->[-1][-1]; } sub _pop_stack_text { $_[0]->_private->{last_state} = pop @{ $_[0]->_private->{states} }; join '', @{ pop @{ $_[0]->_private->{stacks} } }; } sub _stack_state { $_[0]->_private->{states}->[-1]; } sub _save { my ($self, $text) = @_; push @{ $self->_private->{stacks}->[-1] }, $text; # return $text; # DEBUG } sub _save_line { my ($self, $text) = @_; $self->_save($text . $/); } # For paragraphs, etc. sub _save_block { my ($self, $text) = @_; $self->_stack_state->{blocks}++; $self->_save_line($self->_indent($text) . $/); } ## Formatting ## sub _chomp_all { my ($self, $text) = @_; 1 while chomp $text; return $text; } sub _indent { my ($self, $text) = @_; my $level = $self->_private->{indent}; if( $level ){ my $indent = ' ' x ($level * 4); # Capture text on the line so that we don't indent blank lines (/^\x20{4}$/). $text =~ s/^(.+)/$indent$1/mg; } return $text; } sub as_markdown { my ($parser, %args) = @_; my @header; # Don't add meta tags again if we've already done it. if( $args{with_meta} && !$parser->include_meta_tags ){ @header = $parser->_build_markdown_head; } return join("\n" x 2, @header, $parser->{_as_markdown_}); } sub _build_markdown_head { my $parser = shift; my $data = $parser->_private; return join "\n", map { qq![[meta \l$_="$data->{$_}"]]! } grep { defined $data->{$_} } qw( Title Author ); } ## Escaping ## # http://daringfireball.net/projects/markdown/syntax#backslash # Markdown provides backslash escapes for the following characters: # # \ backslash # ` backtick # * asterisk # _ underscore # {} curly braces # [] square brackets # () parentheses # # hash mark # + plus sign # - minus sign (hyphen) # . dot # ! exclamation mark # However some of those only need to be escaped in certain places: # * Backslashes *do* need to be escaped or they may be swallowed by markdown. # * Word-surrounding characters (/[`*_]/) *do* need to be escaped mid-word # because the markdown spec explicitly allows mid-word em*pha*sis. # * I don't actually see anything that curly braces are used for. # * Escaping square brackets is enough to avoid accidentally # creating links and images (so we don't need to escape plain parentheses # or exclamation points as that would generate a lot of unnecesary noise). # Parentheses will be escaped in urls (&end_L) to avoid premature termination. # * We don't need a backslash for every hash mark or every hyphen found mid-word, # just the ones that start a line (likewise for plus and dot). # (Those will all be handled by _escape_paragraph_markdown). # Backslash escape markdown characters to avoid having them interpreted. sub _escape_inline_markdown { local $_ = $_[1]; # s/([\\`*_{}\[\]()#+-.!])/\\$1/g; # See comments above. s/([\\`*_\[\]])/\\$1/g; return $_; } # Escape markdown characters that would be interpreted # at the start of a line. sub _escape_paragraph_markdown { local $_ = $_[1]; # Escape headings, horizontal rules, (unordered) lists, and blockquotes. s/^([-+#>])/\\$1/mg; # Markdown doesn't support backslash escapes for equal signs # even though they can be used to underline a header. # So use html to escape them to avoid having them interpreted. s/^([=])/sprintf '&#x%x;', ord($1)/mge; # Escape the dots that would wrongfully create numbered lists. s/^( (?:>\s+)? \d+ ) (\.\x20)/$1\\$2/xgm; return $_; } ## Parsing ## sub handle_text { my ($self, $text) = @_; # Markdown is for html, so use html entities. $text =~ s/ / /g if $self->_private->{nbsp}; # Unless we're in a code span or verbatim block. unless( $self->_private->{no_escape} ){ # We could, in theory, alter what gets escaped according to context # (for example, escape square brackets (but not parens) inside link text). # The markdown produced might look slightly nicer but either way you're # at the whim of the markdown processor to interpret things correctly. # For now just escape everything. # Don't let literal characters be interpreted as markdown. $text = $self->_escape_inline_markdown($text); } $self->_save($text); } sub start_Document { my ($self) = @_; $self->_new_stack; } sub end_Document { my ($self) = @_; $self->_check_search_header; my $end = pop @{ $self->_private->{stacks} }; @{ $self->_private->{stacks} } == 0 or die 'Document ended with stacks remaining'; my @doc = $self->_chomp_all(join('', @$end)) . $/; if( $self->include_meta_tags ){ unshift @doc, $self->_build_markdown_head, ($/ x 2); } print { $self->{output_fh} } @doc; } ## Blocks ## sub start_Verbatim { my ($self) = @_; $self->_new_stack; $self->_private->{no_escape} = 1; } sub end_Verbatim { my ($self) = @_; my $text = $self->_pop_stack_text; $text = $self->_indent_verbatim($text); $self->_private->{no_escape} = 0; # Verbatim blocks do not generate a separate "Para" event. $self->_save_block($text); } sub _indent_verbatim { my ($self, $paragraph) = @_; # NOTE: Pod::Simple expands the tabs for us (as suggested by perlpodspec). # Pod::Simple also has a 'strip_verbatim_indent' attribute # but it doesn't sound like it gains us anything over this method. # POD verbatim can start with any number of spaces (or tabs) # markdown should be 4 spaces (or a tab) # so indent any paragraphs so that all lines start with at least 4 spaces my @lines = split /\n/, $paragraph; my $indent = ' ' x 4; foreach my $line ( @lines ){ next unless $line =~ m/^( +)/; # find the smallest indentation $indent = $1 if length($1) < length($indent); } if( (my $smallest = length($indent)) < 4 ){ # invert to get what needs to be prepended $indent = ' ' x (4 - $smallest); # Prepend indent to each line. # We could check /\S/ to only indent non-blank lines, # but it's backward compatible to respect the whitespace. # Additionally, both pod and markdown say they ignore blank lines # so it shouldn't hurt to leave them in. $paragraph = join "\n", map { length($_) ? $indent . $_ : '' } @lines; } return $paragraph; } sub start_Para { $_[0]->_new_stack; } sub end_Para { my ($self) = @_; my $text = $self->_pop_stack_text; $text = $self->_escape_paragraph_markdown($text); $self->_save_block($text); } ## Headings ## sub start_head1 { $_[0]->_start_head(1) } sub end_head1 { $_[0]->_end_head(1) } sub start_head2 { $_[0]->_start_head(2) } sub end_head2 { $_[0]->_end_head(2) } sub start_head3 { $_[0]->_start_head(3) } sub end_head3 { $_[0]->_end_head(3) } sub start_head4 { $_[0]->_start_head(4) } sub end_head4 { $_[0]->_end_head(4) } sub _check_search_header { my ($self) = @_; # Save the text since the last heading if we want it for metadata. if( my $last = $self->_private->{search_header} ){ for( $self->_private->{$last} = $self->_last_string ){ s/\A\s+//; s/\s+\z//; } } } sub _start_head { my ($self) = @_; $self->_check_search_header; $self->_new_stack; } sub _end_head { my ($self, $num) = @_; my $h = '#' x $num; my $text = $self->_pop_stack_text; $self->_private->{search_header} = $text =~ /NAME/ ? 'Title' : $text =~ /AUTHOR/ ? 'Author' : undef; # TODO: option for $h suffix # TODO: put a name="" if $self->{embed_anchor_tags}; ? # https://rt.cpan.org/Ticket/Display.html?id=57776 $self->_save_block(join(' ', $h, $text)); } ## Lists ## # TODO: over_empty sub _start_list { my ($self) = @_; $self->_new_stack; # Nest again b/c start_item will pop this to look for preceding content. $self->_increase_indent; $self->_new_stack; } sub _end_list { my ($self) = @_; $self->_handle_between_item_content; # Finish the list. # All the child elements should be blocks, # but don't end with a double newline. my $text = $self->_chomp_all($self->_pop_stack_text); # FIXME: $_[0]->_save_line($text . $/); } sub _handle_between_item_content { my ($self) = @_; # This might be empty (if the list item had no additional content). if( my $text = $self->_pop_stack_text ){ # Else it's a sub-document. # If there are blocks we need to separate with blank lines. if( $self->_private->{last_state}->{blocks} ){ $text = $/ . $text; } # If not, we can condense the text. # In this module's history there was a patch contributed to specifically # produce "huddled" lists so we'll try to maintain that functionality. else { $text = $self->_chomp_all($text) . $/; } $self->_save($text) } $self->_decrease_indent; } sub _start_item { my ($self) = @_; $self->_handle_between_item_content; $self->_new_stack; } sub _end_item { my ($self, $marker) = @_; $self->_save_line($self->_indent($marker . ' ' . $self->_pop_stack_text)); # Store any possible contents in a new stack (like a sub-document). $self->_increase_indent; $self->_new_stack; } sub start_over_bullet { $_[0]->_start_list } sub end_over_bullet { $_[0]->_end_list } sub start_item_bullet { $_[0]->_start_item } sub end_item_bullet { $_[0]->_end_item('-') } sub start_over_number { $_[0]->_start_list } sub end_over_number { $_[0]->_end_list } sub start_item_number { $_[0]->_start_item; # It seems like this should be a stack, # but from testing it appears that the corresponding 'end' event # comes right after the text (it doesn't surround any embedded content). # See t/nested.t which shows start-item, text, end-item, para, start-item.... $_[0]->_private->{item_number} = $_[1]->{number}; } sub end_item_number { my ($self) = @_; $self->_end_item($self->_private->{item_number} . '.'); } # Markdown doesn't support definition lists # so do regular (unordered) lists with indented paragraphs. sub start_over_text { $_[0]->_start_list } sub end_over_text { $_[0]->_end_list } sub start_item_text { $_[0]->_start_item } sub end_item_text { $_[0]->_end_item('-')} # perlpodspec equates an over/back region with no items to a blockquote. sub start_over_block { # NOTE: We don't actually need to indent for a blockquote. $_[0]->_new_stack; } sub end_over_block { my ($self) = @_; # Chomp first to avoid prefixing a blank line with a `>`. my $text = $self->_chomp_all($self->_pop_stack_text); # NOTE: Paragraphs will already be escaped. # I don't really like either of these implementations # but the join/map/split seems a little better and benches a little faster. # You would lose the last newline but we've already chomped. #$text =~ s{^(.)?}{'>' . (defined($1) && length($1) ? (' ' . $1) : '')}mge; $text = join $/, map { length($_) ? '> ' . $_ : '>' } split qr-$/-, $text; $self->_save_block($text); } ## Custom Formats ## sub start_for { my ($self, $attr) = @_; $self->_new_stack; if( $attr->{target} eq 'html' ){ # Use another stack so we can indent # (not syntactily necessary but seems appropriate). $self->_new_stack; $self->_increase_indent; $self->_private->{no_escape} = 1; # Mark this so we know to undo it. $self->_stack_state->{for_html} = 1; } } sub end_for { my ($self) = @_; # Data gets saved as a block (which will handle indents), # but if there was html we'll alter this, so chomp and save a block again. my $text = $self->_chomp_all($self->_pop_stack_text); if( $self->_private->{last_state}->{for_html} ){ $self->_private->{no_escape} = 0; # Save it to the next stack up so we can pop it again (we made two stacks). $self->_save($text); $self->_decrease_indent; $text = join "\n", '
', $self->_chomp_all($self->_pop_stack_text), '
'; } $self->_save_block($text); } # Data events will be emitted for any formatted regions that have been enabled # (by default, `markdown` and `html`). sub start_Data { my ($self) = @_; # TODO: limit this to what's in attr? $self->_private->{no_escape}++; $self->_new_stack; } sub end_Data { my ($self) = @_; my $text = $self->_pop_stack_text; $self->_private->{no_escape}--; $self->_save_block($text); } ## Codes ## sub start_B { $_[0]->_save('**') } sub end_B { $_[0]->start_B() } sub start_I { $_[0]->_save('_') } sub end_I { $_[0]->start_I() } sub start_C { my ($self) = @_; $self->_new_stack; $self->_private->{no_escape}++; } sub end_C { my ($self) = @_; $self->_private->{no_escape}--; $self->_save( $self->_wrap_code_span($self->_pop_stack_text) ); } # Use code spans for F<>. sub start_F { shift->start_C(@_); } sub end_F { shift ->end_C(@_); } sub start_S { $_[0]->_private->{nbsp}++; } sub end_S { $_[0]->_private->{nbsp}--; } sub start_L { my ($self, $flags) = @_; $self->_new_stack; push @{ $self->_private->{link} }, $flags; } sub end_L { my ($self) = @_; my $flags = pop @{ $self->_private->{link} } or die 'Invalid state: link end with no link start'; my ($type, $to, $section) = @{$flags}{qw( type to section )}; my $url = ( $type eq 'url' ? $to : $type eq 'man' ? $self->format_man_url($to, $section) : $type eq 'pod' ? $self->format_perldoc_url($to, $section) : undef ); my $text = $self->_pop_stack_text; # NOTE: I don't think the perlpodspec says what to do with L<|blah> # but it seems like a blank link text just doesn't make sense if( !length($text) ){ $text = $section ? $to ? sprintf('"%s" in %s', $section, $to) : ('"' . $section . '"') : $to; } # FIXME: What does Pod::Simple::X?HTML do for this? # if we don't know how to handle the url just print the pod back out if (!$url) { $self->_save(sprintf 'L<%s>', $flags->{raw}); return; } # In the url we need to escape quotes and parentheses lest markdown # break the url (cut it short and/or wrongfully interpret a title). # Backslash escapes do not work for the space and quotes. # URL-encoding the space is not sufficient # (the quotes confuse some parsers and produce invalid html). # I've arbitratily chosen HTML encoding to hide them from markdown # while mangling the url as litle as possible. $url =~ s/([ '"])/sprintf '&#x%x;', ord($1)/ge; # We also need to double any backslashes that may be present # (lest they be swallowed up) and stop parens from breaking the url. $url =~ s/([\\()])/\\$1/g; # TODO: put section name in title if not the same as $text $self->_save('[' . $text . '](' . $url . ')'); } sub start_X { $_[0]->_new_stack; } sub end_X { my ($self) = @_; my $text = $self->_pop_stack_text; # TODO: mangle $text? # TODO: put if configured } # A code span can be delimited by multiple backticks (and a space) # similar to pod codes (C<< code >>), so ensure we use a big enough # delimiter to not have it broken by embedded backticks. sub _wrap_code_span { my ($self, $arg) = @_; my $longest = 0; while( $arg =~ /([`]+)/g ){ my $len = length($1); $longest = $len if $longest < $len; } my $delim = '`' x ($longest + 1); my $pad = $longest > 0 ? ' ' : ''; return $delim . $pad . $arg . $pad . $delim; } ## Link Formatting (TODO: Move this to another module) ## sub format_man_url { my ($self, $to) = @_; my ($page, $part) = ($to =~ /^ ([^(]+) (?: \( (\S+) \) )? /x); return $self->man_url_prefix . ($part || 1) . '/' . ($page || $to); } sub format_perldoc_url { my ($self, $name, $section) = @_; my $url_prefix = $self->perldoc_url_prefix; my $url = ''; # If the link is to another module (external link). if ($name) { $url = $url_prefix . $name; } # See https://rt.cpan.org/Ticket/Display.html?id=57776 # for a discussion on the need to mangle the section. if ($section){ my $method = $url # If we already have a prefix on the url it's external. ? $self->perldoc_fragment_format # Else an internal link points to this markdown doc. : $self->markdown_fragment_format; $method = 'format_fragment_' . $method unless ref($method); { # Set topic to enable code refs to be simple. local $_ = $section; $section = $self->$method($section); } $url .= '#' . $section; } return $url; } # TODO: simple, pandoc, etc? sub format_fragment_markdown { my ($self, $section) = @_; # If this is an internal link (to another section in this doc) # we can't be sure what the heading id's will look like # (it depends on what is rendering the markdown to html) # but we can try to follow popular conventions. # http://johnmacfarlane.net/pandoc/demo/example9/pandocs-markdown.html#header-identifiers-in-html-latex-and-context #$section =~ s/(?![-_.])[[:punct:]]//g; #$section =~ s/\s+/-/g; $section =~ s/\W+/-/g; $section =~ s/-+$//; $section =~ s/^-+//; $section = lc $section; #$section =~ s/^[^a-z]+//; $section ||= 'section'; return $section; } { # From Pod::Simple::XHTML 3.28. # The strings gets passed through encode_entities() before idify(). # If we don't do it here the substitutions below won't operate consistently. # encode_entities { my %entities = ( q{>} => 'gt', q{<} => 'lt', q{'} => '#39', q{"} => 'quot', q{&} => 'amp', ); my $ents = join '', keys %entities; # } sub format_fragment_pod_simple_xhtml { my ($self, $t) = @_; # encode_entities { $t =~ s/([$ents])/'&' . ($entities{$1} || sprintf '#x%X', ord $1) . ';'/ge; # } # idify { for ($t) { s/<[^>]+>//g; # Strip HTML. s/&[^;]+;//g; # Strip entities. s/^\s+//; s/\s+$//; # Strip white space. s/^([^a-zA-Z]+)$/pod$1/; # Prepend "pod" if no valid chars. s/^[^a-zA-Z]+//; # First char must be a letter. s/[^-a-zA-Z0-9_:.]+/-/g; # All other chars must be valid. s/[-:.]+$//; # Strip trailing punctuation. } # } return $t; } } sub format_fragment_pod_simple_html { my ($self, $section) = @_; # From Pod::Simple::HTML 3.28. # section_name_tidy { $section =~ s/^\s+//; $section =~ s/\s+$//; $section =~ tr/ /_/; $section =~ tr/\x00-\x1F\x80-\x9F//d if 'A' eq chr(65); # drop crazy characters #$section = $self->unicode_escape_url($section); # unicode_escape_url { $section =~ s/([^\x00-\xFF])/'('.ord($1).')'/eg; # Turn char 1234 into "(1234)" # } $section = '_' unless length $section; return $section; # } } sub format_fragment_metacpan { shift->format_fragment_pod_simple_xhtml(@_); } sub format_fragment_sco { shift->format_fragment_pod_simple_html(@_); } 1; __END__ #line 1265 DBIx-Class-Schema-PopulateMore-0.19/inc/Module/AutoInstall.pm000644 000766 000024 00000062254 12415571430 024014 0ustar00johnstaff000000 000000 #line 1 package Module::AutoInstall; use strict; use Cwd (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.12'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps, $UpgradeDeps ); my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps, $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps, $PostambleActionsListAllDeps, $PostambleUsed, $NoTest); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub _installdeps_target { $InstallDepsTarget = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) { $UpgradeDeps = 1; __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::getcwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward compatibility while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. my $cur = _version_of($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { if (not defined $cur) # indeed missing { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; } else { # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above print "too old. ($cur < $arg)\n"; } push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or $InstallDepsTarget or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN) ) { require Config; my $make = $Config::Config{make}; if ($InstallDepsTarget) { print "*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n"; } else { print "*** Dependencies will be installed the next time you type '$make'.\n"; } # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; return (@Existing, @Missing); } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; if ($ENV{PERL5_CPANM_IS_RUNNING}) { return _running_under('cpanminus'); } my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89') { if ($cpan_env) { return _running_under('CPAN'); } return; # CPAN.pm new enough, don't need to check further } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed, @modules_to_upgrade ); while (my ($pkg, $ver) = splice(@_, 0, 2)) { # grep out those already installed if (_version_cmp(_version_of($pkg), $ver) >= 0) { push @installed, $pkg; if ($UpgradeDeps) { push @modules_to_upgrade, $pkg, $ver; } } else { push @modules, $pkg, $ver; } } if ($UpgradeDeps) { push @modules, @modules_to_upgrade; @installed = (); @modules_to_upgrade = (); } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } push @config, 'prereqs', $value; } elsif ( $key eq 'force' ) { push @config, $key, $value; } elsif ( $key eq 'notest' ) { push @config, 'skiptest', $value; } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^(?:force|notest)$/; # pseudo-option $CPAN::Config->{$opt} = $arg; } if ($args{notest} && (not CPAN::Shell->can('notest'))) { die "Your version of CPAN is too old to support the 'notest' pragma"; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = do { if ($args{force}) { CPAN::Shell->force( install => $pkg ) } elsif ($args{notest}) { CPAN::Shell->notest( install => $pkg ) } else { CPAN::Shell->install($pkg) } }; $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::getcwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # report version without loading a module sub _version_of { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; foreach my $dir ( @INC ) { next if ref $dir; my $path = File::Spec->catfile($dir, $file); next unless -e $path; require ExtUtils::MM_Unix; return ExtUtils::MM_Unix->parse_version($path); } return undef; } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to # CPAN::HandleConfig->load. CPAN reports that the redirection # is deprecated in a warning printed at the user. # CPAN-1.81 expects CPAN::HandleConfig->load, does not have # $CPAN::HandleConfig::VERSION but cannot handle # CPAN::Config->load # Which "versions expect CPAN::Config->load? if ( $CPAN::HandleConfig::VERSION || CPAN::HandleConfig->can('load') ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison # return values same as <=> sub _version_cmp { my ( $cur, $min ) = @_; return -1 unless defined $cur; # if 0 keep comparing return 1 unless $min; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return version->new($cur) <=> version->new($min); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return Sort::Versions::versioncmp( $cur, $min ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return $cur <=> $min; } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); my $deps_list = join( ',', @Missing, @Existing ); $PostambleActionsUpgradeDeps = "\$(PERL) $0 --config=$config --upgradedeps=$deps_list"; my $config_notest = join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}), 'notest', 1 ) if $Config; $PostambleActionsNoTest = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); $PostambleActionsUpgradeDepsNoTest = "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list"; $PostambleActionsListDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing); my @all = (@Missing, @Existing); $PostambleActionsListAllDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; my $fragment; $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget; config :: installdeps \t\$(NOECHO) \$(NOOP) AUTO_INSTALL $fragment .= <<"END_MAKE"; checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions installdeps_notest :: \t$PostambleActionsNoTest upgradedeps :: \t$PostambleActionsUpgradeDeps upgradedeps_notest :: \t$PostambleActionsUpgradeDepsNoTest listdeps :: \t$PostambleActionsListDeps listalldeps :: \t$PostambleActionsListAllDeps END_MAKE return $fragment; } 1; __END__ #line 1197 DBIx-Class-Schema-PopulateMore-0.19/inc/Module/Install/000755 000766 000024 00000000000 12415571446 022623 5ustar00johnstaff000000 000000 DBIx-Class-Schema-PopulateMore-0.19/inc/Module/Install.pm000644 000766 000024 00000030133 12415571427 023160 0ustar00johnstaff000000 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.006; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.12'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $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 /\n/, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # 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($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. DBIx-Class-Schema-PopulateMore-0.19/inc/Module/Install/AutoInstall.pm000644 000766 000024 00000004162 12415571430 025414 0ustar00johnstaff000000 000000 #line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.12'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub AutoInstall { $_[0] } sub run { my $self = shift; $self->auto_install_now(@_); } sub write { my $self = shift; $self->auto_install(@_); } sub auto_install { my $self = shift; return if $self->{done}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; my @config = @_; # We'll need Module::AutoInstall $self->include('Module::AutoInstall'); require Module::AutoInstall; my @features_require = Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); my %seen; my @requires = map @$_, map @$_, grep ref, $self->requires; while (my ($mod, $ver) = splice(@requires, 0, 2)) { $seen{$mod}{$ver}++; } my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @deduped; while (my ($mod, $ver) = splice(@features_require, 0, 2)) { push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; } $self->requires(@deduped); $self->makemaker_args( Module::AutoInstall::_make_args() ); my $class = ref($self); $self->postamble( "# --- $class section:\n" . Module::AutoInstall::postamble() ); } sub installdeps_target { my ($self, @args) = @_; $self->include('Module::AutoInstall'); require Module::AutoInstall; Module::AutoInstall::_installdeps_target(1); $self->auto_install(@args); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; DBIx-Class-Schema-PopulateMore-0.19/inc/Module/Install/AutoLicense.pm000644 000766 000024 00000003166 12415571430 025373 0ustar00johnstaff000000 000000 #line 1 package Module::Install::AutoLicense; use strict; use warnings; use base qw(Module::Install::Base); use vars qw($VERSION); $VERSION = '0.08'; my %licenses = ( perl => 'Software::License::Perl_5', apache => 'Software::License::Apache_2_0', artistic => 'Software::License::Artistic_1_0', artistic_2 => 'Software::License::Artistic_2_0', lgpl2 => 'Software::License::LGPL_2_1', lgpl3 => 'Software::License::LGPL_3_0', bsd => 'Software::License::BSD', gpl => 'Software::License::GPL_1', gpl2 => 'Software::License::GPL_2', gpl3 => 'Software::License::GPL_3', mit => 'Software::License::MIT', mozilla => 'Software::License::Mozilla_1_1', ); sub auto_license { my $self = shift; return unless $Module::Install::AUTHOR; my %opts = @_; $opts{lc $_} = delete $opts{$_} for keys %opts; my $holder = $opts{holder} || _get_authors( $self ); #my $holder = $opts{holder} || $self->author; my $license = $self->license(); unless ( defined $licenses{ $license } ) { warn "No license definition for '$license', aborting\n"; return 1; } my $class = $licenses{ $license }; eval "require $class"; my $sl = $class->new( { holder => $holder } ); open LICENSE, '>LICENSE' or die "$!\n"; print LICENSE $sl->fulltext; close LICENSE; $self->postamble(<<"END"); distclean :: license_clean license_clean: \t\$(RM_F) LICENSE END return 1; } sub _get_authors { my $self = shift; my $joined = join ', ', @{ $self->author() || [] }; return $joined; } 'Licensed to auto'; __END__ #line 125 DBIx-Class-Schema-PopulateMore-0.19/inc/Module/Install/AutoManifest.pm000644 000766 000024 00000001257 12415571430 025556 0ustar00johnstaff000000 000000 #line 1 use strict; use warnings; package Module::Install::AutoManifest; use Module::Install::Base; BEGIN { our $VERSION = '0.003'; our $ISCORE = 1; our @ISA = qw(Module::Install::Base); } sub auto_manifest { my ($self) = @_; return unless $Module::Install::AUTHOR; die "auto_manifest requested, but no MANIFEST.SKIP exists\n" unless -e "MANIFEST.SKIP"; if (-e "MANIFEST") { unlink('MANIFEST') or die "Can't remove MANIFEST: $!"; } $self->postamble(<<"END"); create_distdir: manifest_clean manifest distclean :: manifest_clean manifest_clean: \t\$(RM_F) MANIFEST END } 1; __END__ #line 48 #line 131 1; # End of Module::Install::AutoManifest DBIx-Class-Schema-PopulateMore-0.19/inc/Module/Install/Base.pm000644 000766 000024 00000002147 12415571427 024036 0ustar00johnstaff000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.12'; } # 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 DBIx-Class-Schema-PopulateMore-0.19/inc/Module/Install/Can.pm000644 000766 000024 00000006157 12415571430 023664 0ustar00johnstaff000000 000000 #line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.12'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; 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 236 DBIx-Class-Schema-PopulateMore-0.19/inc/Module/Install/Fetch.pm000644 000766 000024 00000004627 12415571430 024214 0ustar00johnstaff000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.12'; @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; DBIx-Class-Schema-PopulateMore-0.19/inc/Module/Install/Homepage.pm000644 000766 000024 00000000613 12415571430 024677 0ustar00johnstaff000000 000000 #line 1 package Module::Install::Homepage; use strict; use warnings; use 5.006; our $VERSION = '0.01'; use base qw(Module::Install::Base); sub auto_set_homepage { my $self = shift; if ($self->name) { $self->homepage(sprintf "http://search.cpan.org/dist/%s/", $self->name) } else { warn "can't set homepage if 'name' is not set\n"; } } 1; __END__ #line 93 DBIx-Class-Schema-PopulateMore-0.19/inc/Module/Install/Include.pm000644 000766 000024 00000001015 12415571430 024532 0ustar00johnstaff000000 000000 #line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.12'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; DBIx-Class-Schema-PopulateMore-0.19/inc/Module/Install/Makefile.pm000644 000766 000024 00000027437 12415571427 024712 0ustar00johnstaff000000 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.12'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-separated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 DBIx-Class-Schema-PopulateMore-0.19/inc/Module/Install/ManifestSkip.pm000644 000766 000024 00000001130 12415571430 025542 0ustar00johnstaff000000 000000 #line 1 use strict; use warnings; package Module::Install::ManifestSkip; our $VERSION = '0.24'; use base 'Module::Install::Base'; our $AUTHOR_ONLY = 1; my $skip_file = "MANIFEST.SKIP"; sub manifest_skip { my $self = shift; return unless $self->is_admin; require Module::Manifest::Skip; print "Writing $skip_file\n"; open OUT, '>', $skip_file or die "Can't open $skip_file for output: $!";; print OUT Module::Manifest::Skip->new->text; close OUT; $self->clean_files('MANIFEST'); $self->clean_files($skip_file) if grep /^clean$/, @_; } 1; DBIx-Class-Schema-PopulateMore-0.19/inc/Module/Install/Metadata.pm000644 000766 000024 00000043302 12415571427 024702 0ustar00johnstaff000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.12'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) [\s|;]* /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}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 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashes delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; DBIx-Class-Schema-PopulateMore-0.19/inc/Module/Install/ReadmeMarkdownFromPod.pm000644 000766 000024 00000003243 12415571427 027351 0ustar00johnstaff000000 000000 #line 1 package Module::Install::ReadmeMarkdownFromPod; use 5.006; use strict; use warnings; our $VERSION = '0.03'; use base qw(Module::Install::Base); sub readme_markdown_from { my ($self, $file, $clean) = @_; return unless $Module::Install::AUTHOR; die "syntax: readme_markdown_from $file, [$clean]\n" unless $file; # require, not use because otherwise Makefile.PL will complain if # non-authors don't have Pod::Markdown, which would be bad. require Pod::Markdown; $self->admin->copy_package('Pod::Markdown', $INC{'Pod/Markdown.pm'}); my $parser = Pod::Markdown->new; $parser->parse_from_file($file); open my $fh, '>', 'README.mkdn' or die "$!\n"; print $fh $parser->as_markdown; close $fh or die "$!\n"; return 1 unless $clean; $self->postamble(<<"END"); distclean :: license_clean license_clean: \t\$(RM_F) README.mkdn END 1; } sub readme_markdown_from_pod { my ($self, $clean) = @_; return unless $Module::Install::AUTHOR; unless ($self->Meta->{values}{all_from}) { die "set 'all_from' or use 'readme_markdown_from'\n"; } $self->readme_markdown_from($self->Meta->{values}{all_from}, $clean); } sub readme_from_pod { my ($self, $clean) = @_; return unless $Module::Install::AUTHOR; unless ($self->Meta->{values}{all_from}) { die "set 'all_from' or use 'readme_from'\n"; } $self->readme_from($self->Meta->{values}{all_from}, $clean); } sub reference_module { my ($self, $file) = @_; die "syntax: reference_module $file\n" unless $file; $self->all_from($file); $self->readme_from($file); $self->readme_markdown_from($file); } 1; __END__ #line 188 DBIx-Class-Schema-PopulateMore-0.19/inc/Module/Install/Repository.pm000644 000766 000024 00000004256 12415571430 025340 0ustar00johnstaff000000 000000 #line 1 package Module::Install::Repository; use strict; use 5.005; use vars qw($VERSION); $VERSION = '0.06'; use base qw(Module::Install::Base); sub _execute { my ($command) = @_; `$command`; } sub auto_set_repository { my $self = shift; return unless $Module::Install::AUTHOR; my $repo = _find_repo(\&_execute); if ($repo) { $self->repository($repo); } else { warn "Cannot determine repository URL\n"; } } sub _find_repo { my ($execute) = @_; if (-e ".git") { # TODO support remote besides 'origin'? if ($execute->('git remote show -n origin') =~ /URL: (.*)$/m) { # XXX Make it public clone URL, but this only works with github my $git_url = $1; $git_url =~ s![\w\-]+\@([^:]+):!git://$1/!; return $git_url; } elsif ($execute->('git svn info') =~ /URL: (.*)$/m) { return $1; } } elsif (-e ".svn") { if (`svn info` =~ /URL: (.*)$/m) { return $1; } } elsif (-e "_darcs") { # defaultrepo is better, but that is more likely to be ssh, not http if (my $query_repo = `darcs query repo`) { if ($query_repo =~ m!Default Remote: (http://.+)!) { return $1; } } open my $handle, '<', '_darcs/prefs/repos' or return; while (<$handle>) { chomp; return $_ if m!^http://!; } } elsif (-e ".hg") { if ($execute->('hg paths') =~ /default = (.*)$/m) { my $mercurial_url = $1; $mercurial_url =~ s!^ssh://hg\@(bitbucket\.org/)!https://$1!; return $mercurial_url; } } elsif (-e "$ENV{HOME}/.svk") { # Is there an explicit way to check if it's an svk checkout? my $svk_info = `svk info` or return; SVK_INFO: { if ($svk_info =~ /Mirrored From: (.*), Rev\./) { return $1; } if ($svk_info =~ m!Merged From: (/mirror/.*), Rev\.!) { $svk_info = `svk info /$1` or return; redo SVK_INFO; } } return; } } 1; __END__ =encoding utf-8 #line 128 DBIx-Class-Schema-PopulateMore-0.19/inc/Module/Install/Win32.pm000644 000766 000024 00000003403 12415571430 024054 0ustar00johnstaff000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.12'; @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; DBIx-Class-Schema-PopulateMore-0.19/inc/Module/Install/WriteAll.pm000644 000766 000024 00000002376 12415571430 024705 0ustar00johnstaff000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.12'; @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;