Getopt-Lucid-1.08/000755 000765 000024 00000000000 13074555746 014214 5ustar00davidstaff000000 000000 Getopt-Lucid-1.08/Changes000644 000765 000024 00000013121 13074555746 015505 0ustar00davidstaff000000 000000 Revision history for Perl module Getopt::Lucid 1.08 2017-04-15 22:49:56-04:00 America/New_York - Fixed for perls without . in @INC 1.07 2016-08-20 21:53:47-04:00 America/New_York - update SYNOPSIS to correct a bug 1.06 2016-01-11 11:18:37-05:00 America/New_York - update contributors and repository metadata 1.05 2013-03-28 20:01:43 America/New_York - work around parsing bug in perl 5.12 1.04 2013-03-27 11:58:02 America/New_York - added error message for missing values for other option types as well - fixed some documentation typos - removed documentation of 'required' modifier, which was actually removed in 1.00 1.03 2013-03-27 10:23:55 America/New_York - added error message for missing parameter value 1.02 2013-03-22 23:44:15 America/New_York - added newlines to error messages 1.01 2012-02-23 18:07:19 EST5EDT - fixed validation() to make hashref argument actually optional like the documentation says it is [rt.cpan.org #74269] - fixed typos in Pod 1.00 2011-12-10 23:32:42 EST5EDT - new() takes optional hashref of parameters - Remove global $STRICT and replace with 'strict' object parameter - Remove 'required' modifier for parameters and provide a new 'validate' method for late checking of prerequisites - Fix missing $VERSION 0.19 2010-11-05 17:07:26 EST5EDT - Added valid() modifier and deprecated old way of validating options - Added getopts() as an alias for getopt() - Allows setting param default to undef [Robert Bohne] 0.18 Thu Mar 12 00:11:11 EDT 2009 - Options with validation specs will not fail just because the option is not seen on the command line. Validation is now only done on default values provided in the spec or in merge/append/replace (to ensure consistency) and on options that appear on the command line. 0.17 Thu Feb 21 07:15:40 EST 2008 - Clarify 5.006 as minimum requirement; updated other minimum requirements - A repeated param option now replaces instead of throwing an error - Fix for ambiguous param bug (RT#33462, patch from Torsten Link) - Updated distribution packaging (custom Build.PL, author tests moved to xt/ directory, documentation with Pod::WikiDoc, etc.) - Changed to the Apache License, version 2.0; (it's clearer, relicensable, and is explicit about contributions) 0.16 Thu Aug 17 23:04:38 EDT 2006 - Required Param options with validation no longer throw and error from failing to validate the default empty-string (fixes RT#20938) - Clarified documentation about validation and default values - Various Pod revisions 0.14 Wed Feb 8 11:32:22 EST 2006 - fixed typo in Pod - removed Test::Exception dependencies - removed 5.006 specific syntax - added optional pod/podcoverage tests (skipped by default) - switching to even numbering for releases 0.12 Tue Sep 20 13:10:19 EDT 2005 - added support for option names with GNU-style dashes; accessors substitute underscore for dashes. (Suggested by Steven Vasilogianis) 0.11 Sat Jul 30 11:03:46 EDT 2005 - moved build_requires prereqs into requires to work around a CPANPLUS bug for users preferring Build.PL - replaced Clone::Any::clone with Storable::dclone for fewer non-core dependencies - removed Cookbook stub for now 0.10 Tue Jul 12 19:28:59 EDT 2005 - Single character (alphanumeric) switches - Exception-based error handling - Specification validation - Command-line validation against spec - Bundled single-character switches - Long-style (alphanumeric) switches - Long/short/multiple switch aliases - Keys in resulting option hash are names stripped of any leading dashes - Option names/aliases must be unique - Option termination string "--" - Counters - Parameters (w/o "=") (values can't be ambiguous) - Parameters (w "=") - Lists - Pass through non-options (preserving order) - Throw exceptions on unrecognized non-bareword options - Check for valid and invalid option name characters - Keypairs (e.g. "--define os=linux") - Bareword options - Required options - Default values - Case insensitivity - Validation (regex) - Validation (code subroutine) - Dependencies - parse other arrays than @ARGV - names() function - accessors for options in spec - merge() function - pass through single dash - provide separate merge_default() and add_default() functions - require option_spec for new() - make getopt call new if called as a class function and return the object not a hash of options - provide defaults() and reset_defaults() functions - rename push_defaults to append_defaults - make sure merge_defaults ignores anything not in the spec - implement replace_defaults() - make *_defaults check that lists/keypairs are passing right type - Support *_defaults() taking a hashref or a hash as input - revamp argument spec to new, simpler format - validation on lists (validate each value) - validation on keypairs (simple validation for keys/values as a whole) - "magic" mode as the default: take barewords in spec and handle any form that appears to match it - add "strict" argument to use for less magic on names/aliases - Negation (only for switch/counter/parameter bare/longform): sets to zero/undef - Negation with = (for list/keypair bare/longform): removes matching element/key - Negation without = (for list/keypair bare/longform): blanks entire list/hash Getopt-Lucid-1.08/CONTRIBUTING.mkdn000644 000765 000024 00000006604 13074555746 017004 0ustar00davidstaff000000 000000 ## HOW TO CONTRIBUTE Thank you for considering contributing to this distribution. This file contains instructions that will help you work with the source code. The distribution is managed with Dist::Zilla. This means that many of the usual files you might expect are not in the repository, but are generated at release time, as is much of the documentation. Some generated files are kept in the repository as a convenience (e.g. Makefile.PL or cpanfile). Generally, **you do not need Dist::Zilla to contribute patches**. You do need Dist::Zilla to create a tarball. See below for guidance. ### Getting dependencies If you have App::cpanminus 1.6 or later installed, you can use `cpanm` to satisfy dependencies like this: $ cpanm --installdeps . Otherwise, look for either a `Makefile.PL` or `cpanfile` file for a list of dependencies to satisfy. ### Running tests You can run tests directly using the `prove` tool: $ prove -l $ prove -lv t/some_test_file.t For most of my distributions, `prove` is entirely sufficient for you to test any patches you have. I use `prove` for 99% of my testing during development. ### Code style and tidying Please try to match any existing coding style. If there is a `.perltidyrc` file, please install Perl::Tidy and use perltidy before submitting patches. If there is a `tidyall.ini` file, you can also install Code::TidyAll and run `tidyall` on a file or `tidyall -a` to tidy all files. ### Patching documentation Much of the documentation Pod is generated at release time. Some is generated boilerplate; other documentation is built from pseudo-POD directives in the source like C<=method> or C<=func>. If you would like to submit a documentation edit, please limit yourself to the documentation you see. If you see typos or documentation issues in the generated docs, please email or open a bug ticket instead of patching. ### Where to send patches and pull requests If you found this distribution on Github, sending a pull-request is the best way to contribute. If a pull-request isn't possible, a bug ticket with a patch file is the next best option. As a last resort, an email to the author(s) is acceptable. ## Installing and using Dist::Zilla Dist::Zilla is not required for contributing, but if you'd like to learn more, this section will get you up to speed. Dist::Zilla is a very powerful authoring tool, optimized for maintaining a large number of distributions with a high degree of automation, but it has a large dependency chain, a bit of a learning curve and requires a number of author-specific plugins. To install it from CPAN, I recommend one of the following approaches for the quickest installation: # using CPAN.pm, but bypassing non-functional pod tests $ cpan TAP::Harness::Restricted $ PERL_MM_USE_DEFAULT=1 HARNESS_CLASS=TAP::Harness::Restricted cpan Dist::Zilla # using cpanm, bypassing *all* tests $ cpanm -n Dist::Zilla In either case, it's probably going to take about 10 minutes. Go for a walk, go get a cup of your favorite beverage, take a bathroom break, or whatever. When you get back, Dist::Zilla should be ready for you. Then you need to install any plugins specific to this distribution: $ cpan `dzil authordeps` $ dzil authordeps | cpanm Once installed, here are some dzil commands you might try: $ dzil build $ dzil test $ dzil xtest You can learn more about Dist::Zilla at http://dzil.org/ Getopt-Lucid-1.08/cpanfile000644 000765 000024 00000002606 13074555746 015724 0ustar00davidstaff000000 000000 requires "Carp" => "0"; requires "Exception::Class" => "1.23"; requires "Exporter" => "0"; requires "Storable" => "2.16"; requires "perl" => "5.006"; requires "strict" => "0"; requires "warnings" => "0"; on 'test' => sub { requires "Data::Dumper" => "0"; requires "Exception::Class::TryCatch" => "1.10"; requires "ExtUtils::MakeMaker" => "0"; requires "File::Spec" => "0"; requires "Test::More" => "0.62"; requires "lib" => "0"; requires "perl" => "5.006"; requires "vars" => "0"; }; on 'test' => sub { recommends "CPAN::Meta" => "2.120900"; }; on 'configure' => sub { requires "ExtUtils::MakeMaker" => "6.17"; requires "perl" => "5.006"; }; on 'develop' => sub { requires "Dist::Zilla" => "5"; requires "Dist::Zilla::PluginBundle::DAGOLDEN" => "0.072"; requires "English" => "0"; requires "File::Spec" => "0"; requires "File::Temp" => "0"; requires "IO::Handle" => "0"; requires "IPC::Open3" => "0"; requires "Pod::Coverage::TrustPod" => "0"; requires "Pod::Wordlist" => "0"; requires "Software::License::Apache_2_0" => "0"; requires "Test::CPAN::Meta" => "0"; requires "Test::MinimumVersion" => "0"; requires "Test::More" => "0"; requires "Test::Pod" => "1.41"; requires "Test::Pod::Coverage" => "1.08"; requires "Test::Portability::Files" => "0"; requires "Test::Spelling" => "0.12"; requires "Test::Version" => "1"; requires "blib" => "1.01"; }; Getopt-Lucid-1.08/dist.ini000644 000765 000024 00000000357 13074555746 015665 0ustar00davidstaff000000 000000 name = Getopt-Lucid author = David Golden license = Apache_2_0 copyright_holder = David Golden [@DAGOLDEN] :version = 0.072 stopwords = keypair stopwords = keypairs stopwords = param Getopt-Lucid-1.08/examples/000755 000765 000024 00000000000 13074555746 016032 5ustar00davidstaff000000 000000 Getopt-Lucid-1.08/lib/000755 000765 000024 00000000000 13074555746 014762 5ustar00davidstaff000000 000000 Getopt-Lucid-1.08/LICENSE000644 000765 000024 00000026354 13074555746 015233 0ustar00davidstaff000000 000000 This software is Copyright (c) 2017 by David Golden. This is free software, licensed under: The Apache License, Version 2.0, January 2004 Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. Copyright [yyyy] [name of copyright owner] Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. Getopt-Lucid-1.08/Makefile.PL000644 000765 000024 00000003073 13074555746 016171 0ustar00davidstaff000000 000000 # This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.009. use strict; use warnings; use 5.006; use ExtUtils::MakeMaker 6.17; my %WriteMakefileArgs = ( "ABSTRACT" => "Clear, readable syntax for command line processing", "AUTHOR" => "David Golden ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => "6.17" }, "DISTNAME" => "Getopt-Lucid", "LICENSE" => "apache", "MIN_PERL_VERSION" => "5.006", "NAME" => "Getopt::Lucid", "PREREQ_PM" => { "Carp" => 0, "Exception::Class" => "1.23", "Exporter" => 0, "Storable" => "2.16", "strict" => 0, "warnings" => 0 }, "TEST_REQUIRES" => { "Data::Dumper" => 0, "Exception::Class::TryCatch" => "1.10", "ExtUtils::MakeMaker" => 0, "File::Spec" => 0, "Test::More" => "0.62", "lib" => 0, "vars" => 0 }, "VERSION" => "1.08", "test" => { "TESTS" => "t/*.t" } ); my %FallbackPrereqs = ( "Carp" => 0, "Data::Dumper" => 0, "Exception::Class" => "1.23", "Exception::Class::TryCatch" => "1.10", "Exporter" => 0, "ExtUtils::MakeMaker" => 0, "File::Spec" => 0, "Storable" => "2.16", "Test::More" => "0.62", "lib" => 0, "strict" => 0, "vars" => 0, "warnings" => 0 ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); Getopt-Lucid-1.08/MANIFEST000644 000765 000024 00000001346 13074555746 015351 0ustar00davidstaff000000 000000 # This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.009. CONTRIBUTING.mkdn Changes LICENSE MANIFEST META.json META.yml Makefile.PL README Todo cpanfile dist.ini examples/cpanget lib/Getopt/Lucid.pm lib/Getopt/Lucid/Exception.pm perlcritic.rc t/00-new.t t/00-report-prereqs.dd t/00-report-prereqs.t t/01-exceptions.t t/02-getopt.t t/03-getopt-notargv.t t/04-names.t t/05-accessors.t t/06-default-handling.t t/07-magic-names.t t/08-strict-names.t t/09-negation.t t/10-default-validation.t t/ErrorMessages.pm xt/author/00-compile.t xt/author/critic.t xt/author/pod-coverage.t xt/author/pod-spell.t xt/author/pod-syntax.t xt/author/portability.t xt/author/test-version.t xt/release/distmeta.t xt/release/minimum-version.t Getopt-Lucid-1.08/META.json000644 000765 000024 00000006321 13074555746 015637 0ustar00davidstaff000000 000000 { "abstract" : "Clear, readable syntax for command line processing", "author" : [ "David Golden " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.009, CPAN::Meta::Converter version 2.150010", "license" : [ "apache_2_0" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Getopt-Lucid", "no_index" : { "directory" : [ "corpus", "examples", "t", "xt" ], "package" : [ "DB" ] }, "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.17", "perl" : "5.006" } }, "develop" : { "requires" : { "Dist::Zilla" : "5", "Dist::Zilla::PluginBundle::DAGOLDEN" : "0.072", "English" : "0", "File::Spec" : "0", "File::Temp" : "0", "IO::Handle" : "0", "IPC::Open3" : "0", "Pod::Coverage::TrustPod" : "0", "Pod::Wordlist" : "0", "Software::License::Apache_2_0" : "0", "Test::CPAN::Meta" : "0", "Test::MinimumVersion" : "0", "Test::More" : "0", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08", "Test::Portability::Files" : "0", "Test::Spelling" : "0.12", "Test::Version" : "1", "blib" : "1.01" } }, "runtime" : { "requires" : { "Carp" : "0", "Exception::Class" : "1.23", "Exporter" : "0", "Storable" : "2.16", "perl" : "5.006", "strict" : "0", "warnings" : "0" } }, "test" : { "recommends" : { "CPAN::Meta" : "2.120900" }, "requires" : { "Data::Dumper" : "0", "Exception::Class::TryCatch" : "1.10", "ExtUtils::MakeMaker" : "0", "File::Spec" : "0", "Test::More" : "0.62", "lib" : "0", "perl" : "5.006", "vars" : "0" } } }, "provides" : { "Getopt::Lucid" : { "file" : "lib/Getopt/Lucid.pm", "version" : "1.08" }, "Getopt::Lucid::Exception" : { "file" : "lib/Getopt/Lucid/Exception.pm", "version" : "1.08" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/dagolden/getopt-lucid/issues" }, "homepage" : "https://github.com/dagolden/getopt-lucid", "repository" : { "type" : "git", "url" : "https://github.com/dagolden/getopt-lucid.git", "web" : "https://github.com/dagolden/getopt-lucid" } }, "version" : "1.08", "x_authority" : "cpan:DAGOLDEN", "x_contributors" : [ "David Golden ", "David Precious ", "James E Keenan ", "Kevin McGrath ", "Nova Patch ", "Robert Bohne " ], "x_serialization_backend" : "Cpanel::JSON::XS version 3.0225" } Getopt-Lucid-1.08/META.yml000644 000765 000024 00000002717 13074555746 015474 0ustar00davidstaff000000 000000 --- abstract: 'Clear, readable syntax for command line processing' author: - 'David Golden ' build_requires: Data::Dumper: '0' Exception::Class::TryCatch: '1.10' ExtUtils::MakeMaker: '0' File::Spec: '0' Test::More: '0.62' lib: '0' perl: '5.006' vars: '0' configure_requires: ExtUtils::MakeMaker: '6.17' perl: '5.006' dynamic_config: 0 generated_by: 'Dist::Zilla version 6.009, CPAN::Meta::Converter version 2.150010' license: apache meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Getopt-Lucid no_index: directory: - corpus - examples - t - xt package: - DB provides: Getopt::Lucid: file: lib/Getopt/Lucid.pm version: '1.08' Getopt::Lucid::Exception: file: lib/Getopt/Lucid/Exception.pm version: '1.08' requires: Carp: '0' Exception::Class: '1.23' Exporter: '0' Storable: '2.16' perl: '5.006' strict: '0' warnings: '0' resources: bugtracker: https://github.com/dagolden/getopt-lucid/issues homepage: https://github.com/dagolden/getopt-lucid repository: https://github.com/dagolden/getopt-lucid.git version: '1.08' x_authority: cpan:DAGOLDEN x_contributors: - 'David Golden ' - 'David Precious ' - 'James E Keenan ' - 'Kevin McGrath ' - 'Nova Patch ' - 'Robert Bohne ' x_serialization_backend: 'YAML::Tiny version 1.69' Getopt-Lucid-1.08/perlcritic.rc000644 000765 000024 00000001166 13074555746 016706 0ustar00davidstaff000000 000000 severity = 5 verbose = 8 [Variables::ProhibitPunctuationVars] allow = $@ $! [TestingAndDebugging::ProhibitNoStrict] allow = refs [Variables::ProhibitEvilVariables] variables = $DB::single # Turn these off [-BuiltinFunctions::ProhibitStringyEval] [-ControlStructures::ProhibitPostfixControls] [-ControlStructures::ProhibitUnlessBlocks] [-Documentation::RequirePodSections] [-InputOutput::ProhibitInteractiveTest] [-References::ProhibitDoubleSigils] [-RegularExpressions::RequireExtendedFormatting] [-InputOutput::ProhibitTwoArgOpen] [-Modules::ProhibitEvilModules] # Turn this on [Lax::ProhibitStringyEval::ExceptForRequire] Getopt-Lucid-1.08/README000644 000765 000024 00000064466 13074555746 015114 0ustar00davidstaff000000 000000 NAME Getopt::Lucid - Clear, readable syntax for command line processing VERSION version 1.08 SYNOPSIS use Getopt::Lucid qw( :all ); # basic option specifications with aliases @specs = ( Switch("version|V"), Counter("verbose|v"), Param("config|C"), List("lib|l|I"), Keypair("define"), Switch("help|h") ); $opt = Getopt::Lucid->getopt( \@specs )->validate; $verbosity = $opt->get_verbose; @libs = $opt->get_lib; %defs = $opt->get_define; %all_options = $opt->options; # advanced option specifications @adv_spec = ( Param("input"), Param("mode")->default("tcp"), # defaults Param("host")->needs("port"), # dependencies Param("port")->valid(qr/\d+/), # regex validation Param("config")->valid(sub { -r }),# custom validation Param("help")->anycase, # case insensitivity ); $opt = Getopt::Lucid->getopt( \@adv_spec ); $opt->validate({ 'requires' => ['input'] }); # example with a config file $opt = Getopt::Lucid->getopt( \@adv_spec ); use Config::Std; if ( -r $opt->get_config ) { read_config( $opt->get_config() => my %config_hash ); $opt->merge_defaults( $config_hash{''} ); } DESCRIPTION The goal of this module is providing good code readability and clarity of intent for command-line option processing. While readability is a subjective standard, Getopt::Lucid relies on a more verbose, plain-English option specification as compared against the more symbolic approach of Getopt::Long. Key features include: * Five option types: switches, counters, parameters, lists, and key pairs * Three option styles: long, short (including bundled), and bare (without dashes) * Specification of defaults, required options and option dependencies * Validation of options with regexes or subroutines * Negation of options on the command line * Support for parsing any array, not just the default @ARGV * Incorporation of external defaults (e.g. from a config file) with user control of precedence USAGE Option Styles, Naming and "Strictness" Getopt::Lucid support three kinds of option styles: long-style ("--foo"), short-style ("-f") and bareword style ("foo"). Short-style options are automatically unbundled during command line processing if a single dash is followed by more than one letter (e.g. "-xzf" becomes "-x -z -f" ). Each option is identified in the specification with a string consisting of the option "name" followed by zero or more "aliases", with any alias (and each subsequent alias) separated by a vertical bar character. E.g.: "lib|l|I" means name "lib", alias "l" and alias "I" Names and aliases must begin with an alphanumeric character, but subsequently may also include both underscore and dash. (E.g. both "input-file" and "input_file" are valid.) While names and aliases are interchangeable when provided on the command line, the "name" portion is used with the accessors for each option (see "Accessors and Mutators"). Any of the names and aliases in the specification may be given in any of the three styles. By default, Getopt::Lucid works in "magic" mode, in which option names or aliases may be specified with or without leading dashes, and will be parsed from the command line whether or not they have corresponding dashes. Single-character names or aliases may be read with no dash, one dash or two dashes. Multi-character names or aliases must have either no dashes or two dashes. E.g.: * Both "foo" and "--foo" as names in the specification may be read from the command line as either "--foo" or "foo" * The specification name "f" may be read from the command line as "--f", "-f", or just "f" In practice, this means that the specification need not use dashes, but if used on the command line, they will be treated appropriately. Alternatively, Getopt::Lucid can operate in "strict" mode by setting the C parameter to a true value. In strict mode, option names and aliases may still be specified in any of the three styles, but they will only be parsed from the command line if they are used in exactly the same style. E.g., given the name and alias "--help|-h", only "--help" and "-h" are valid for use on the command line. Option Specification Constructors Options specifications are provided to Getopt::Lucid in an array. Entries in the array must be created with one of several special constructor functions that return a specification object. These constructor functions may be imported either individually or as a group using the import tag ":all" (e.g. "use Getopt::Lucid qw(:all);"). The form of the constructor is: TYPE( NAME_ARGUMENT ); The constructor function name indicates the type of option. The name argument is a string with the names and aliases separated by vertical bar characters. The five option specification constructors are: Switch() A true/false value. Defaults to false. The appearance of an option of this type on the command line sets it to true. Counter() A numerical counter. Defaults to 0. The appearance of an option of this type on the command line increments the counter by one. Param() A variable taking an argument. Defaults to "" (the empty string). When an option of this type appears on the command line, the value of the option is set in one of two ways -- appended with an equals sign or from the next argument on the command line: --name=value --name value In the case where white space is used to separate the option name and the value, if the value looks like an option, an exception will be thrown: --name --value # throws an exception List() This is like "Param()" but arguments are pushed onto a list. The default list is empty. Keypair() A variable taking an argument pair, which are added to a hash. Arguments are handled as with "Param()", but the argument itself must have a key and value joined by an equals sign. --name=key=value --name key=value Option modifiers An option specification can be further modified with the following methods, each of which return the object modified so that modifier chaining is possible. E.g.: @spec = ( Param("input")->default("/dev/random")->needs("output"), Param("output)->default("/dev/null"), ); valid() Sets the validation parameter(s) for an option. @spec = ( Param("port")->valid(qr/\d+/), # regex validation Param("config")->valid(sub { -r }), # custom validation Keypair("define") ->valid(\&_valid_key, \&valid_value), # keypairs take two ); See the "Validation" section, below, for more. default() Changes the default for the option to the argument(s) of "default()". List and hashes can take either a list or a reference to an array or hash, respectively. @spec = ( Switch("debug")->default(1), Counter("verbose")->default(3), Param("config")->default("/etc/profile"), List("dirs")->default(qw( /var /home )), Keypair("define")->default( arch => "i386" ), ); needs() Takes as an argument a list of option names or aliases of dependencies. If the option this modifies appears on the command line, each of the options given as an argument must appear on the command line as well or an exception is thrown. @spec = ( Param("input")->needs("output"), Param("output), ); anycase() Indicates that the associated option names/aliases may appear on the command line in lowercase, uppercase, or any mixture of the two. No argument is needed. @spec = ( Switch("help|h")->anycase(), # "Help", "HELP", etc. ); Validation Validation happens in two stages. First, individual parameters may have validation criteria added to them. Second, the parsed options object may be validated by checking that all requirements collectively are met. Parameter validation The Param, List, and Keypair option types may be provided an optional validation specification. Values provided on the command line will be validated according to the specification or an exception will be thrown. A validation specification can be either a regular expression, or a reference to a subroutine. Keypairs take up to two validation specifiers. The first is applied to keys and the second is applied to values; either can be left undef to ignore validation. (More complex validation of specific values for specific keys must be done manually.) Validation is also applied to default values provided via the "default()" modifier or later modified with "append_defaults", "merge_defaults", or "replace_defaults". This ensures internal consistency. If no default is explicitly provided, validation is only applied if the option appears on the command line. (In other words, the built-in defaults are always considered valid if the option does not appear.) If this is not desired, the "required" option to the "validate" method should be used to force users to provide an explicit value. # Must be provided and is thus always validated @spec = ( Param("width")->valid(qr/\d+/) ); $opt = Getopt::Lucid->getopt(\@spec); $opt->validate( {requires => ['width']} ); For validation subroutines, the value found on the command line is passed as the first element of @_, and $_ is also set equal to the first element. (N.B. Changing $_ will not change the value that is captured.) The value validates if the subroutine returns a true value. For validation with regular expressions, consider using Regexp::Common for a ready library of validation options. Older versions of Getopt::Lucid used validation arguments provided in the Spec constructor. This is still supported, but is deprecated and discouraged. It may be removed in a future version of Getopt::Lucid. # deprecated Param("height", qr/\d+/) Options object validation The "validate" method should be called on the result of "getopt". This will check that all parameter prerequisites defined by "needs" have been met. It also takes a hashref of arguments. The optional "requires" argument gives an arrayref of parameters that must exist. The reason that object validation is done separate from "getopt" is to allow for better control over different options that might be required or to allow some dependencies (i.e. from "needs") to be met via a configuration file. @spec = ( Param("action")->needs(qw/user password/), Param("user"), Param("password"), ); $opt = Getopt::Lucid->getopt(\@spec); $opt->merge_defaults( read_config() ); # provides 'user' & 'password' $opt->validate({requires => ['action']}); Parsing the Command Line Technically, Getopt::Lucid scans an array for command line options, not a command-line string. By default, this array is @ARGV (though other arrays can be used -- see "new()"), which is typically provided by the operating system according to system-specific rules. When Getopt::Lucid processes the array, it scans the array in order, removing any specified command line options and any associated arguments, and leaving behind any unrecognized elements in the array. If an element consisting solely of two-dashes ("--") is found, array scanning is terminated at that point. Any options found during scanning are applied in order. E.g.: @ARGV = qw( --lib /tmp --lib /var ); my $opt = Getopt::Lucid->getopt( [ List("lib") ] ); print join ", " $opt->lib; # prints "/tmp, /var" If an element encountered in processing begins with a dash, but is not recognized as a short-form or long-form option name or alias, an exception will be thrown. Negation Getopt::Lucid also supports negating options. Options are negated if the option is specified with "no-" or "--no-" prefixed to a name or alias. By default, negation clears the option: Switch and Counter options are set to zero; Param options are set to ""; List and Keypair options are set to an empty list and empty hash, respectively. For List and Keypair options, it is also possible to negate a specific list element or hash key by placing an equals sign and the list element or key immediately after the option name: --no-lib=/tmp --no-define=arch # removes "/tmp" from lib and the "arch" key from define As with all options, negation is processed in order, allowing a "reset" in the middle of command line processing. This may be useful for those using command aliases who wish to "switch off" options in the alias. E.g, in Unix: $ alias wibble = wibble.pl --verbose $ wibble --no-verbose # @ARGV would contain ( "--verbose", "--no-verbose" ) This also may have applications in post-processing configuration files (see "Managing Defaults and Config Files"). Accessors and Mutators After processing the command-line array, the values of the options may be read or modified using accessors/mutators of the form "get_NAME" and "set_NAME", where NAME represents the option name in the specification without any leading dashes. E.g. @spec = ( Switch("--test|-t"), List("--lib|-L"), Keypair("--define|-D"), ); $opt = Getopt::Lucid->getopt( \@spec ); print $opt->get_test ? "True" : "False"; $opt->set_test(1); For option names with dashes, underscores should be substituted in the accessor calls. E.g. @spec = ( Param("--input-file|-i") ); $opt = Getopt::Lucid->getopt( \@spec ); print $opt->get_input_file; This can create an ambiguous case if a similar option exists with underscores in place of dashes. (E.g. "input_file" and "input-file".) Users can safely avoid these problems by choosing to use either dashes or underscores exclusively and not mixing the two styles. List and Keypair options are returned as flattened lists: my @lib = $opt->get_lib; my %define = $opt->get_define; Using the "set_NAME" mutator is not recommended and should be used with caution. No validation is performed and changes will be lost if the results of processing the command line array are recomputed (e.g, such as occurs if new defaults are applied). List and Keypair options mutators take a list, not references. Managing Defaults and Config Files A typical problem for command-line option processing is the precedence relationship between default option values specified within the program, default option values stored in a configuration file or in environment variables, and option values specified on the command-line, particularly when the command-line specifies an alternate configuration file. Getopt::Lucid takes the following approach to this problem: * Initial default values may be specified as part of the option specification (using the "default()" modifier) * Default values from the option specification may be modified or replaced entirely with default values provided in an external hash (such as from a standard config file or environment variables) * When the command-line array is processed, options and their arguments are stored in the order they appeared in the command-line array * The stored options are applied in-order to modify or replace the set of "current" default option values * If default values are subsequently changed (such as from an alternative configuration file), the stored options are re-applied in-order to the new set of default option values With this approach, the resulting option set is always the result of applying options (or negations) from the command-line array to a set of default-values. Users have complete freedom to apply whatever precedence rules they wish to the default values and may even change default values after the command-line array is processed without losing the options given on the command line. Getopt::Lucid provides several functions to assist in manipulating default values: * "merge_defaults()" -- new defaults overwrite any matching, existing defaults. KeyPairs hashes and List arrays are replaced entirely with new defaults * "append_defaults()" -- new defaults overwrite any matching, existing defaults, except for Counter and List options, which have the new defaults added and appended, respectively, and KeyPair options, which are flattened into any existing default hash * "replace_defaults()" -- new defaults replace existing defaults; any options not provided in the new defaults are reset to zero/empty, ignoring any default given in the option specification * "reset_defaults()" -- returns defaults to values given in the options specification Exceptions and Error Handling Getopt::Lucid uses Exception::Class for exceptions. When a major error occurs, Getopt::Lucid will die and throw one of three Exception::Class subclasses: * "Getopt::Lucid::Exception::Usage" -- thrown when Getopt::Lucid methods are called incorrectly * "Getopt::Lucid::Exception::Spec" -- thrown when the specification array contains incorrect or invalid data * "Getopt::Lucid::Exception::ARGV" -- thrown when the command-line is processed and fails to pass specified validation, requirements, or is otherwise determined to be invalid These exception may be caught using an "eval" block and allow the calling program to respond differently to each class of exception. my $opt; eval { $opt = Getopt::Lucid->getopt( \@spec ) }; if ($@) { print "$@\n" && print_usage() && exit 1 if ref $@ eq 'Getopt::Lucid::Exception::ARGV'; ref $@ ? $@->rethrow : die $@; } Ambiguous Cases and Gotchas One-character aliases and "anycase" @spec = ( Counter("verbose|v")->anycase, Switch("version|V")->anycase, ); Consider the spec above. By specifying "anycase" on these, "verbose", "Verbose", "VERBOSE" are all acceptable, as are "version", "Version" and so on. (Including long-form versions of these, too, if "magic" mode is used.) However, what if the command line has "-v" or even "-v -V"? In this case, the rule is that exact case matches are used before case-insensitive matches are searched. Thus, "-v" can only match "verbose", despite the "anycase" modification, and likewise "-V" can only match "version". Identical names except for dashes and underscores @spec = ( Param("input-file"), Switch("input_file"), ); Consider the spec above. These are two, separate, valid options, but a call to the accessor "get_input_file" is ambiguous and may return either option, depending on which first satisfies a "fuzzy-matching" algorithm inside the accessor code. Avoid identical names with mixed dash and underscore styles. METHODS new() $opt = Getopt::Lucid->new( \@option_spec ); $opt = Getopt::Lucid->new( \@option_spec, \%parameters ); $opt = Getopt::Lucid->new( \@option_spec, \@option_array ); $opt = Getopt::Lucid->new( \@option_spec, \@option_array, \%parameters ); Creates a new Getopt::Lucid object. An array reference to an option spec is required as an argument. (See "USAGE" for a description of the object spec). By default, objects will be set to read @ARGV for command line options. An optional second argument with a reference to an array will use that array for option processing instead. The final argument may be a hashref of parameters. The only valid parameter currently is: * strict -- enables strict mode when true For typical cases, users will likely prefer to call "getopt" instead, which creates a new object and parses the command line with a single function call. validate() $opt->validate(); $opt->validate( \%arguments ); Takes an optional argument hashref, validates that all requirements and prerequisites are met or throws an error. Valid argument keys are: * "requires" -- an arrayref of options that must exist in the options object. This method returns the object for convenient chaining: $opt = Getopt::Lucid->getopt(\@spec)->validate; append_defaults() %options = append_defaults( %config_hash ); %options = append_defaults( \%config_hash ); Takes a hash or hash reference of new default values, modifies the stored defaults, recalculates the result of processing the command line with the revised defaults, and returns a hash with the resulting options. Each key/value pair in the passed hash is added to the stored defaults. For Switch and Param options, the value in the passed hash will overwrite any preexisting value. For Counter options, the value is added to any preexisting value. For List options, the value (or values, if the value is an array reference) will be pushed onto the end of the list of existing values. For Keypair options, the key/value pairs will be added to the existing hash, overwriting existing key/value pairs (just like merging two hashes). Keys which are not valid names from the options specification will be ignored. defaults() %defaults = $opt->defaults(); Returns a hash containing current default values. Keys are names from the option specification (without any leading dashes). These defaults represent the baseline values that are modified by the parsed command line options. getopt() $opt = Getopt::Lucid->getopt( \@option_spec ); $opt = Getopt::Lucid->getopt( \@option_spec, \@option_array ); $opt->getopt(); Parses the command line array (@ARGV by default). When called as a class function, "getopt" takes the same arguments as "new", calls "new" to create an object before parsing the command line, and returns the new object. When called as an object method, it takes no arguments and returns itself. For convenience, C is a alias for C. merge_defaults() %options = merge_defaults( %config_hash ); %options = merge_defaults( \%config_hash ); Takes a hash or hash reference of new default values, modifies the stored defaults, recalculates the result of processing the command line with the revised defaults, and returns a hash with the resulting options. Each key/value pair in the passed hash is added to the stored defaults, overwriting any preexisting value. Keys which are not valid names from the options specification will be ignored. names() @names = $opt->names(); Returns the list of names in the options specification. Each name represents a key in the hash of options provided by "options". options() %options = $opt->options(); Returns a deep copy of the options hash. Before "getopt" is called, its behavior is undefined. After "getopt" is called, this will return the result of modifying the defaults with the results of command line processing. replace_defaults() %options = replace_defaults( %config_hash ); %options = replace_defaults( \%config_hash ); Takes a hash or hash reference of new default values, replaces the stored defaults, recalculates the result of processing the command line with the revised defaults, and returns a hash with the resulting options. Each key/value pair in the passed hash replaces existing defaults, including those given in the option specifications. Keys which are not valid names from the option specification will be ignored. reset_defaults() %options = reset_defaults(); Resets the stored defaults to the original values from the options specification, recalculates the result of processing the command line with the restored defaults, and returns a hash with the resulting options. This undoes the effect of a "merge_defaults" or "add_defaults" call. API CHANGES In 1.00, the following API changes have been made: * "new()" now takes an optional hashref of parameters as the last argument * The global $STRICT variable has been replaced with a per-object parameter "strict" * The "required" modifier has been removed and a new "validate" method has been added to facilitate late/custom checks of required options SEE ALSO * Config::Tiny * Config::Simple * Config::Std * Getopt::Long * Regexp::Common BUGS Please report any bugs or feature using the CPAN Request Tracker. Bugs can be submitted through the web interface at When submitting a bug or request, please include a test-file or a patch to an existing test-file that illustrates the bug or desired feature. SUPPORT Bugs / Feature Requests Please report any bugs or feature requests through the issue tracker at . You will be notified automatically of any progress on your issue. Source Code This is open source software. The code repository is available for public review and contribution under the terms of the license. git clone https://github.com/dagolden/getopt-lucid.git AUTHOR David Golden CONTRIBUTORS * David Golden * David Precious * James E Keenan * Kevin McGrath * Nova Patch * Robert Bohne COPYRIGHT AND LICENSE This software is Copyright (c) 2017 by David Golden. This is free software, licensed under: The Apache License, Version 2.0, January 2004 Getopt-Lucid-1.08/t/000755 000765 000024 00000000000 13074555746 014457 5ustar00davidstaff000000 000000 Getopt-Lucid-1.08/Todo000644 000765 000024 00000004061 13074555746 015045 0ustar00davidstaff000000 000000 TODO list for Perl module Getopt::Lucid #--------------------------------------------------------------------------# # Bugs #--------------------------------------------------------------------------# - repeated parameters should be OK -- later should override. Could add a "unique" modifier for original behavior #--------------------------------------------------------------------------# # Features to add #--------------------------------------------------------------------------# - new option types: - Version( $string ) -- defaults to "--version" and preempts exceptions - prints $VERSION of script - Help( $string ) -- defaults to "--help|-h|-?" and preempts exceptions - prints any usage information defined in spec? - optional coderef to handle help (given rest of command line as args) - create spec modifier with coderef to denote a potential command - dispatch to command immediately when seen & pass the rest of the array for further processing -- maybe gets back modified command line if it comes back at all - commands() function to give list of command seen on command line (?) - dispatch() function to call, in order, the list of commands (?) - Usage information in spec and printed by a separate function - optional name for params usage("msg", "FILE") --> --input=FILE - usage("msg", "LABEL", "VALUE") --> --keypair LABEL=VALUE - For keypair validation, pass *both* key and value to a validation subroutine (allowing custom validation by key) - Callbacks (?) - option to allow unrecognized dash-prefixed options without exception - "cuddle" parameters -- e.g. "-Ilib" is "-I lib" #--------------------------------------------------------------------------# # Bugfixes/technical/other #--------------------------------------------------------------------------# - test how negation is handled under $STRICT - write cookbook - refactor ugly code (module and tests) - Allow keypairs to escape an equals sign for use in keys(?) -- e.g. "define is\==value" giving "is=" => "value" (Does anyone really need this?) Getopt-Lucid-1.08/xt/000755 000765 000024 00000000000 13074555746 014647 5ustar00davidstaff000000 000000 Getopt-Lucid-1.08/xt/author/000755 000765 000024 00000000000 13074555746 016151 5ustar00davidstaff000000 000000 Getopt-Lucid-1.08/xt/release/000755 000765 000024 00000000000 13074555746 016267 5ustar00davidstaff000000 000000 Getopt-Lucid-1.08/xt/release/distmeta.t000644 000765 000024 00000000172 13074555746 020266 0ustar00davidstaff000000 000000 #!perl # This file was automatically generated by Dist::Zilla::Plugin::MetaTests. use Test::CPAN::Meta; meta_yaml_ok(); Getopt-Lucid-1.08/xt/release/minimum-version.t000644 000765 000024 00000000266 13074555746 021616 0ustar00davidstaff000000 000000 #!perl use Test::More; eval "use Test::MinimumVersion"; plan skip_all => "Test::MinimumVersion required for testing minimum versions" if $@; all_minimum_version_ok( qq{5.010} ); Getopt-Lucid-1.08/xt/author/00-compile.t000644 000765 000024 00000002721 13074555746 020205 0ustar00davidstaff000000 000000 use 5.006; use strict; use warnings; # this test was generated with Dist::Zilla::Plugin::Test::Compile 2.056 use Test::More; plan tests => 3; my @module_files = ( 'Getopt/Lucid.pm', 'Getopt/Lucid/Exception.pm' ); # fake home for cpan-testers use File::Temp; local $ENV{HOME} = File::Temp::tempdir( CLEANUP => 1 ); my @switches = ( -d 'blib' ? '-Mblib' : '-Ilib', ); use File::Spec; use IPC::Open3; use IO::Handle; open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; my @warnings; for my $lib (@module_files) { # see L my $stderr = IO::Handle->new; diag('Running: ', join(', ', map { my $str = $_; $str =~ s/'/\\'/g; q{'} . $str . q{'} } $^X, @switches, '-e', "require q[$lib]")) if $ENV{PERL_COMPILE_TEST_DEBUG}; my $pid = open3($stdin, '>&STDERR', $stderr, $^X, @switches, '-e', "require q[$lib]"); binmode $stderr, ':crlf' if $^O eq 'MSWin32'; my @_warnings = <$stderr>; waitpid($pid, 0); is($?, 0, "$lib loaded ok"); shift @_warnings if @_warnings and $_warnings[0] =~ /^Using .*\bblib/ and not eval { require blib; blib->VERSION('1.01') }; if (@_warnings) { warn @_warnings; push @warnings, @_warnings; } } is(scalar(@warnings), 0, 'no warnings found') or diag 'got warnings: ', ( Test::More->can('explain') ? Test::More::explain(\@warnings) : join("\n", '', @warnings) ); Getopt-Lucid-1.08/xt/author/critic.t000644 000765 000024 00000000435 13074555746 017615 0ustar00davidstaff000000 000000 #!perl use strict; use warnings; use Test::More; use English qw(-no_match_vars); eval "use Test::Perl::Critic"; plan skip_all => 'Test::Perl::Critic required to criticise code' if $@; Test::Perl::Critic->import( -profile => "perlcritic.rc" ) if -e "perlcritic.rc"; all_critic_ok(); Getopt-Lucid-1.08/xt/author/pod-coverage.t000644 000765 000024 00000000334 13074555746 020711 0ustar00davidstaff000000 000000 #!perl # This file was automatically generated by Dist::Zilla::Plugin::PodCoverageTests. use Test::Pod::Coverage 1.08; use Pod::Coverage::TrustPod; all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' }); Getopt-Lucid-1.08/xt/author/pod-spell.t000644 000765 000024 00000000616 13074555746 020240 0ustar00davidstaff000000 000000 use strict; use warnings; use Test::More; # generated by Dist::Zilla::Plugin::Test::PodSpelling 2.007004 use Test::Spelling 0.12; use Pod::Wordlist; add_stopwords(); all_pod_files_spelling_ok( qw( bin lib ) ); __DATA__ Bohne David Exception Getopt Golden James Keenan Kevin Lucid McGrath Nova Patch Precious Robert dagolden davidp jkeenan keypair keypairs kmcgrath lib param patch rbo xdg Getopt-Lucid-1.08/xt/author/pod-syntax.t000644 000765 000024 00000000252 13074555746 020443 0ustar00davidstaff000000 000000 #!perl # This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. use strict; use warnings; use Test::More; use Test::Pod 1.41; all_pod_files_ok(); Getopt-Lucid-1.08/xt/author/portability.t000644 000765 000024 00000000322 13074555746 020675 0ustar00davidstaff000000 000000 use strict; use warnings; use Test::More; eval 'use Test::Portability::Files'; plan skip_all => 'Test::Portability::Files required for testing portability' if $@; options(test_one_dot => 0); run_tests(); Getopt-Lucid-1.08/xt/author/test-version.t000644 000765 000024 00000000637 13074555746 021006 0ustar00davidstaff000000 000000 use strict; use warnings; use Test::More; # generated by Dist::Zilla::Plugin::Test::Version 1.09 use Test::Version; my @imports = qw( version_all_ok ); my $params = { is_strict => 0, has_version => 1, multiple => 0, }; push @imports, $params if version->parse( $Test::Version::VERSION ) >= version->parse('1.002'); Test::Version->import(@imports); version_all_ok; done_testing; Getopt-Lucid-1.08/t/00-new.t000644 000765 000024 00000002630 13074555746 015653 0ustar00davidstaff000000 000000 use strict; use Test::More; use Data::Dumper; use Exception::Class::TryCatch; # Work around win32 console buffering that can show diags out of order Test::More->builder->failure_output(*STDOUT) if $ENV{HARNESS_VERBOSE}; use Getopt::Lucid ':all'; use Getopt::Lucid::Exception; sub why { my %vars = @_; $Data::Dumper::Sortkeys = 1; return "\n" . Data::Dumper->Dump([values %vars],[keys %vars]) . "\n"; } #--------------------------------------------------------------------------# # Test cases #--------------------------------------------------------------------------# my $spec = [ Switch('t'), Counter('v'), Param('f'), List('I'), Keypair('d'), ]; my $num_tests = 6 ; plan tests => $num_tests ; my ($gl, $err); eval { $gl = Getopt::Lucid->new() }; catch $err; is( $err, "Getopt::Lucid->new() requires an option specification array reference\n", "new without spec throws exception"); eval { $gl = Getopt::Lucid->new( $spec ) }; catch $err; is( $err, undef, "new with spec succeeds"); isa_ok( $gl, "Getopt::Lucid" ); eval { $gl = Getopt::Lucid->getopt() }; catch $err; is( $err, "Getopt::Lucid->getopt() requires an option specification array reference\n", "getopt (as class method) without spec throws exception"); eval { $gl = Getopt::Lucid->getopt( $spec ) }; catch $err; is( $err, undef, "getopt (as class method) with spec succeeds"); isa_ok( $gl, "Getopt::Lucid" ); Getopt-Lucid-1.08/t/00-report-prereqs.dd000644 000765 000024 00000005504 13074555746 020203 0ustar00davidstaff000000 000000 do { my $x = { 'configure' => { 'requires' => { 'ExtUtils::MakeMaker' => '6.17', 'perl' => '5.006' } }, 'develop' => { 'requires' => { 'Dist::Zilla' => '5', 'Dist::Zilla::PluginBundle::DAGOLDEN' => '0.072', 'English' => '0', 'File::Spec' => '0', 'File::Temp' => '0', 'IO::Handle' => '0', 'IPC::Open3' => '0', 'Pod::Coverage::TrustPod' => '0', 'Pod::Wordlist' => '0', 'Software::License::Apache_2_0' => '0', 'Test::CPAN::Meta' => '0', 'Test::MinimumVersion' => '0', 'Test::More' => '0', 'Test::Pod' => '1.41', 'Test::Pod::Coverage' => '1.08', 'Test::Portability::Files' => '0', 'Test::Spelling' => '0.12', 'Test::Version' => '1', 'blib' => '1.01' } }, 'runtime' => { 'requires' => { 'Carp' => '0', 'Exception::Class' => '1.23', 'Exporter' => '0', 'Storable' => '2.16', 'perl' => '5.006', 'strict' => '0', 'warnings' => '0' } }, 'test' => { 'recommends' => { 'CPAN::Meta' => '2.120900' }, 'requires' => { 'Data::Dumper' => '0', 'Exception::Class::TryCatch' => '1.10', 'ExtUtils::MakeMaker' => '0', 'File::Spec' => '0', 'Test::More' => '0.62', 'lib' => '0', 'perl' => '5.006', 'vars' => '0' } } }; $x; }Getopt-Lucid-1.08/t/00-report-prereqs.t000644 000765 000024 00000012714 13074555746 020060 0ustar00davidstaff000000 000000 #!perl use strict; use warnings; # This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.025 use Test::More tests => 1; use ExtUtils::MakeMaker; use File::Spec; # from $version::LAX my $lax_version_re = qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? | (?:\.[0-9]+) (?:_[0-9]+)? ) | (?: v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? | (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? ) )/x; # hide optional CPAN::Meta modules from prereq scanner # and check if they are available my $cpan_meta = "CPAN::Meta"; my $cpan_meta_pre = "CPAN::Meta::Prereqs"; my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic # Verify requirements? my $DO_VERIFY_PREREQS = 1; sub _max { my $max = shift; $max = ( $_ > $max ) ? $_ : $max for @_; return $max; } sub _merge_prereqs { my ($collector, $prereqs) = @_; # CPAN::Meta::Prereqs object if (ref $collector eq $cpan_meta_pre) { return $collector->with_merged_prereqs( CPAN::Meta::Prereqs->new( $prereqs ) ); } # Raw hashrefs for my $phase ( keys %$prereqs ) { for my $type ( keys %{ $prereqs->{$phase} } ) { for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; } } } return $collector; } my @include = qw( ); my @exclude = qw( ); # Add static prereqs to the included modules list my $static_prereqs = do 't/00-report-prereqs.dd'; # Merge all prereqs (either with ::Prereqs or a hashref) my $full_prereqs = _merge_prereqs( ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), $static_prereqs ); # Add dynamic prereqs to the included modules list (if we can) my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; if ( $source && $HAS_CPAN_META && (my $meta = eval { CPAN::Meta->load_file($source) } ) ) { $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); } else { $source = 'static metadata'; } my @full_reports; my @dep_errors; my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; # Add static includes into a fake section for my $mod (@include) { $req_hash->{other}{modules}{$mod} = 0; } for my $phase ( qw(configure build test runtime develop other) ) { next unless $req_hash->{$phase}; next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); for my $type ( qw(requires recommends suggests conflicts modules) ) { next unless $req_hash->{$phase}{$type}; my $title = ucfirst($phase).' '.ucfirst($type); my @reports = [qw/Module Want Have/]; for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { next if $mod eq 'perl'; next if grep { $_ eq $mod } @exclude; my $file = $mod; $file =~ s{::}{/}g; $file .= ".pm"; my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; my $want = $req_hash->{$phase}{$type}{$mod}; $want = "undef" unless defined $want; $want = "any" if !$want && $want == 0; my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; if ($prefix) { my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); $have = "undef" unless defined $have; push @reports, [$mod, $want, $have]; if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { if ( $have !~ /\A$lax_version_re\z/ ) { push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; } elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { push @dep_errors, "$mod version '$have' is not in required range '$want'"; } } } else { push @reports, [$mod, $want, "missing"]; if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { push @dep_errors, "$mod is not installed ($req_string)"; } } } if ( @reports ) { push @full_reports, "=== $title ===\n\n"; my $ml = _max( map { length $_->[0] } @reports ); my $wl = _max( map { length $_->[1] } @reports ); my $hl = _max( map { length $_->[2] } @reports ); if ($type eq 'modules') { splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl]; push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; } else { splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl]; push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports; } push @full_reports, "\n"; } } } if ( @full_reports ) { diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; } if ( @dep_errors ) { diag join("\n", "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n", "The following REQUIRED prerequisites were not satisfied:\n", @dep_errors, "\n" ); } pass; # vim: ts=4 sts=4 sw=4 et: Getopt-Lucid-1.08/t/01-exceptions.t000644 000765 000024 00000002110 13074555746 017235 0ustar00davidstaff000000 000000 # Getopt::Lucid::Exception use strict; use Test::More 0.62; #--------------------------------------------------------------------------# # Test cases #--------------------------------------------------------------------------# my (@exceptions, @throw_aliases); BEGIN { @exceptions = qw( Getopt::Lucid::Exception Getopt::Lucid::Exception::Spec Getopt::Lucid::Exception::ARGV Getopt::Lucid::Exception::Usage ); @throw_aliases = qw( throw_spec throw_argv throw_usage ); } #--------------------------------------------------------------------------# # Test script #--------------------------------------------------------------------------# plan tests => 2 + @exceptions; # Work around win32 console buffering that can show diags out of order Test::More->builder->failure_output(*STDOUT) if $ENV{HARNESS_VERBOSE}; use Getopt::Lucid::Exception; use Getopt::Lucid ':all'; for my $e ( @exceptions ) { eval { $e->throw }; isa_ok ($@, $e,); } can_ok( "Getopt::Lucid$_", @throw_aliases ) for ( "::Exception", "" ); Getopt-Lucid-1.08/t/02-getopt.t000644 000765 000024 00000104775 13074555746 016403 0ustar00davidstaff000000 000000 use strict; use Test::More; use Data::Dumper; use Exception::Class::TryCatch 1.10; use Getopt::Lucid ':all'; use Getopt::Lucid::Exception; use lib "."; use t::ErrorMessages; # Work around win32 console buffering that can show diags out of order Test::More->builder->failure_output(*STDOUT) if $ENV{HARNESS_VERBOSE}; sub why { my %vars = @_; $Data::Dumper::Sortkeys = 1; return "\n" . Data::Dumper->Dump([values %vars],[keys %vars]) . "\n"; } #--------------------------------------------------------------------------# # Test cases #--------------------------------------------------------------------------# my ($num_tests, @bad_specs, @good_specs); BEGIN { push @good_specs, { label => "single short switch", spec => [ Switch("-v"), ], cases => [ { argv => [ qw( -v ) ], result => { "v" => 1 }, desc => "switch present" }, { argv => [ qw( ) ], result => { "v" => 0 }, desc => "switch missing" }, { argv => [ qw( -t ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _invalid_argument("-t"), desc => "invalid command line" }, ] }; push @good_specs, { label => "multiple short switches", spec => [ Switch("-v"), Switch("-t"), ], cases => [ { argv => [ qw( -v -t ) ], result => { "v" => 1, "t" => 1 }, desc => "both switches present" }, { argv => [ qw( -v ) ], result => { "v" => 1, "t" => 0 }, desc => "one switch present" }, { argv => [ qw( ) ], result => { "v" => 0, "t" => 0 }, desc => "both switches missing" }, { argv => [ qw( -f ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _invalid_argument("-f"), desc => "invalid command line" }, ] }; push @good_specs, { label => "bundled short switches", spec => [ Switch("-v"), Switch("-t"), Switch("-r"), ], cases => [ { argv => [ qw( -vrt ) ], result => { "v" => 1, "r" => 1, "t" => 1 }, desc => "three switches present" }, { argv => [ qw( -vt ) ], result => { "v" => 1, "r" => 0, "t" => 1 }, desc => "two switches present" }, { argv => [ qw( -vfrt ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _invalid_argument("-f"), desc => "invalid command line" }, ] }; push @good_specs, { label => "short and long switches", spec => [ Switch("--verbose"), Switch("--test"), Switch("-r"), ], cases => [ { argv => [ qw( --verbose -r --test ) ], result => { "verbose" => 1, "test" => 1, "r" => 1 }, desc => "three switches present (2 long and 1 short)" }, { argv => [ qw( -r --test ) ], result => { "verbose" => 0, "test" => 1, "r" => 1 }, desc => "two switches present (long and short)" }, { argv => [ qw( --test ) ], result => { "verbose" => 0, "test" => 1, "r" => 0 }, desc => "only long switch present" }, { argv => [ qw( --test -v ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _invalid_argument("-v"), desc => "invalid command line" }, ] }; push @good_specs, { label => "option name aliasing", spec => [ Switch("--verbose|-v"), Switch("--test|--debug|-d"), Switch("-r|-s"), ], cases => [ { argv => [ qw( -v -s --debug ) ], result => { "verbose" => 1, "test" => 1, "r" => 1 }, desc => "three switch aliases used" }, { argv => [ qw( -r -d ) ], result => { "verbose" => 0, "test" => 1, "r" => 1 }, desc => "two switches present (alias and regular)" }, { argv => [ qw( --verbose -v ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _switch_twice("--verbose"), desc => "switch used more than once" }, ] }; push @good_specs, { label => "'--' terminates options", spec => [ Switch("--verbose"), Switch("--test"), Switch("-r"), ], cases => [ { argv => [ qw( --verbose -r -- --test ) ], result => { "verbose" => 1, "test" => 0, "r" => 1 }, after => [ qw( --test ) ], desc => "stop after two" }, { argv => [ qw( -- -r --test ) ], result => { "verbose" => 0, "test" => 0, "r" => 0 }, after => [ qw(-r --test ) ], desc => "stop right away" }, ] }; push @good_specs, { label => "two counter", spec => [ Counter("--verbose|-v"), Counter("--count"), ], cases => [ { argv => [ qw( --count --verbose -vv --count ) ], result => { "verbose" => 3, "count" => 2 }, desc => "one counter used twice, other used thrice" }, { argv => [ qw( --verbose -v ) ], result => { "verbose" => 2, "count" => 0 }, desc => "one counter used twice" }, { argv => [ qw( -- ) ], result => { "verbose" => 0, "count" => 0 }, desc => "no counters used" }, ] }; push @good_specs, { label => "parameter w/o '='", spec => [ Counter("--verbose|-v"), Param("--input|-i"), ], cases => [ { argv => [ qw( -- ) ], result => { "verbose" => 0, "input" => undef }, desc => "no options" }, { argv => [ qw( --input 42 -vv ) ], result => { "verbose" => 2, "input" => 42 }, desc => "counters and long-style parameter" }, { argv => [ qw( -vi 42 ) ], result => { "verbose" => 1, "input" => 42 }, desc => "bundled counter and short-style parameter" }, { argv => [ qw( -i 42 --input 3 ) ], result => { "verbose" => 0, "input" => 3 }, desc => "repeated param value" }, { argv => [ qw( --input ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _no_value("--input"), desc => "missing param value" }, { argv => [ qw( -i -v ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _param_ambiguous("--input","-v"), desc => "ambiguous param value" }, ] }; push @good_specs, { label => "parameter w '='", spec => [ Switch("--test|-t"), Counter("--verbose|-v"), Param("--input|-i"), ], cases => [ { argv => [ qw( -- ) ], result => { "verbose" => 0, "input" => undef, "test" => 0 }, desc => "no options" }, { argv => [ qw( --input=42 -vv ) ], result => { "verbose" => 2, "input" => 42, "test" => 0 }, desc => "counters and long-style parameter" }, { argv => [ qw( -vi=42 ) ], result => { "verbose" => 1, "input" => 42, "test" => 0 }, desc => "bundled counter and short-style parameter" }, { argv => [ qw( -i=-v ) ], result => { "verbose" => 0, "input" => "-v", "test" => 0 }, desc => "ambiguous param value ok w '='" }, { argv => [ qw( --test=42 ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _switch_value("--test","42"), desc => "switch with equals" }, { argv => [ qw( --verbose=42 ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _counter_value("--verbose","42"), desc => "counter with equals" }, ] }; push @good_specs, { label => "lists (w or w/o '=')", spec => [ Counter("--verbose|-v"), List("--input|-i"), ], cases => [ { argv => [ qw( -- ) ], result => { "verbose" => 0, "input" => [] }, desc => "no options" }, { argv => [ qw( --input 42 -vv ) ], result => { "verbose" => 2, "input" => [42] }, desc => "counters and one list arg" }, { argv => [ qw( --input 42 -vvi=twelve ) ], result => { "verbose" => 2, "input" => [42,"twelve"] }, desc => "counters and two list args" }, { argv => [ qw( -i -v ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _param_ambiguous("--input","-v"), desc => "ambiguous param value" }, { argv => [ qw( -i=-v --input=-i) ], result => { "verbose" => 0, "input" => ["-v", "-i"] }, desc => "ambiguous param value ok w '='" }, ] }; push @good_specs, { label => "pass through non-switch args", spec => [ Switch("-v"), ], cases => [ { argv => [ qw( word1 -v word2 ) ], result => { "v" => 1 }, after => [ qw( word1 word2 ) ], desc => "switch in middle" }, { argv => [ qw( word1 -v -- -t ) ], result => { "v" => 1 }, after => [ qw( word1 -t ) ], desc => "switch before '--' and arg" }, { argv => [ qw( -v - ) ], result => { "v" => 1 }, after => [ qw( - ) ], desc => "single dash" }, { argv => [ qw( -v -t ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _invalid_argument("-t"), desc => "invalid command line" }, ] }; push @good_specs, { label => "keypairs (w or w/o =)", spec => [ Counter("--verbose|-v"), Keypair("--input|-i"), ], cases => [ { argv => [ qw( -- ) ], result => { "verbose" => 0, "input" => {} }, desc => "no options" }, { argv => [ qw( --input n=42 -vv ) ], result => { "verbose" => 2, "input" => { n => 42} }, desc => "counters and one keypair arg" }, { argv => [ qw( --input n=42 -vvi=p=twelve ) ], result => { "verbose" => 2, "input" => { n => 42, p => "twelve"} }, desc => "counters and two keypair args" }, { argv => [ qw( -i -v ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _keypair("--input"), desc => "keypair missing value (no '=')" }, { argv => [ qw( -i=-v --input=-i) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _keypair("--input"), desc => "keypair missing value (w '=')" }, { argv => [ qw( -i==-v ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _keypair("--input"), desc => "keypair missing key (w '=')" }, ] }; push @good_specs, { label => "bareword options", spec => [ Counter("verbose|v"), Param("input|i"), ], cases => [ { argv => [ qw( -- ) ], result => { "verbose" => 0, "input" => undef }, desc => "no options" }, { argv => [ qw( input 42 v v ) ], result => { "verbose" => 2, "input" => 42 }, desc => "counters and longstyle parameter" }, { argv => [ qw( i 42 input 3 ) ], result => { "verbose" => 0, "input" => 3 }, desc => "repeated param value" }, ] }; push @good_specs, { label => "required options", spec => [ Counter("--verbose|-v"), Param("--input|-i") ], cases => [ { argv => [ qw( -v ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _required("--input"), required => ['input'], desc => "missing required option" }, { argv => [ qw( --input 42 -vv ) ], required => ['input'], result => { "verbose" => 2, "input" => 42 }, desc => "required option present" }, { argv => [ qw( --input info -v ) ], required => ['input'], result => { "verbose" => 1, "input" => 'info' }, desc => "required option param similar to option name" }, ] }; push @good_specs, { label => "default values", spec => [ Switch("--quick")->default(1), Counter("--verbose|-v")->default(1), Param("--input")->default(42), List("--lib")->default(qw( one two )), Keypair("--flag")->default(answer => 42), ], cases => [ { argv => [ qw( ) ], result => { "quick" => 1, "verbose" => 1, "input" => 42, "lib" => [qw( one two )], "flag" => { answer => 42 }, }, desc => "no options" }, { argv => [ qw( -v ) ], result => { "quick" => 1, "verbose" => 2, "input" => 42, "lib" => [qw( one two )], "flag" => { answer => 42 }, }, desc => "one option given, other default" }, { argv => [ qw( --input 23 -vv ) ], result => { "quick" => 1, "verbose" => 3, "input" => 23, "lib" => [qw( one two )], "flag" => { answer => 42 }, }, desc => "two options given" }, ] }; push @good_specs, { label => "case insensitive", spec => [ Counter("--verbose|-v")->default(1)->anycase, Param("--input|-i|-r")->default(42), ], cases => [ { argv => [ qw( ) ], result => { "verbose" => 1, "input" => 42, }, desc => "no options" }, { argv => [ qw( -v ) ], result => { "verbose" => 2, "input" => 42, }, desc => "two lower case options given" }, { argv => [ qw( --verBose -vV -r 23 ) ], result => { "verbose" => 4, "input" => 23, }, desc => "mixed cases for case insensitive (alt)" }, { argv => [ qw( --verBose -vV --input 23 ) ], result => { "verbose" => 4, "input" => 23, }, desc => "mixed cases for case insensitive" }, { argv => [ qw( --INPUT ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _invalid_argument("--INPUT"), desc => "bad case for case sensitive option" }, ] }; push @good_specs, { label => "validate w/ regex", spec => [ Counter("--verbose|-v")->default(1), Param("--input|-i", qr/\d+/)->default(42), List("--lib", qr/\w*/), Keypair("--def", qr/(os)*/, qr/^(win32|linux|mac)/), ], cases => [ { argv => [ qw( ) ], result => { "verbose" => 1, "input" => 42, "lib" => [], "def" => {}, }, desc => "no options" }, { argv => [ qw( --input 23 ) ], result => { "verbose" => 1, "input" => 23, "lib" => [], "def" => {}, }, desc => "param input validates" }, { argv => [ qw( --lib foo --lib bar ) ], result => { "verbose" => 1, "input" => 42, "lib" => [qw(foo bar)], "def" => {}, }, desc => "list input validates" }, { argv => [ qw( --def os=linux ) ], result => { "verbose" => 1, "input" => 42, "lib" => [], "def" => { os => "linux" }, }, desc => "keypair input validates" }, { argv => [ qw( --input twenty-three ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _param_invalid("--input","twenty-three"), desc => "param input not validating" }, { argv => [ qw( --lib foo --lib % ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _list_invalid("--lib","%"), desc => "list input not validating" }, { argv => [ qw( --def os=amiga ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _keypair_invalid("--def","os","amiga"), desc => "keypair value not validating" }, { argv => [ qw( --def arch=i386 ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _keypair_invalid("--def","arch","i386"), desc => "keypair key not validating" }, ] }; push @good_specs, { label => "validate but allow missing options", spec => [ Param( "mode|m", qr/test|live/ ) ], cases => [ { argv => [ qw() ], result => { "mode" => undef, }, desc => "no param validates" }, { argv => [ qw( --mode test ) ], result => { "mode" => 'test', }, desc => "param input validates" }, { argv => [ qw( --mode foo ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _param_invalid("mode","foo"), desc => "param mode not validating" }, ] }; push @good_specs, { label => "validate w/ string alternation regex", spec => [ Param( "mode|m", qr/test|live/ ), ], cases => [ { argv => [ qw( --mode test ) ], required => ['mode'], result => { "mode" => 'test', }, desc => "param input validates" }, { argv => [ qw( --mode foo ) ], required => ['mode'], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _param_invalid("mode","foo"), desc => "param mode not validating" }, ] }; push @good_specs, { label => "validate only keypair key", spec => [ Keypair("--def", qr/(os)*/), ], cases => [ { argv => [ qw( --def os=linux ) ], result => { "def" => { os => "linux" }, }, desc => "keypair input validates" }, { argv => [ qw( --def arch=i386 ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _keypair_invalid("--def","arch", "i386"), desc => "key not validating" }, ] }; push @good_specs, { label => "validate only keypair value", spec => [ Keypair("--def", undef, qr/(linux|win32)*/), ], cases => [ { argv => [ qw( --def os=linux ) ], result => { "def" => { os => "linux" }, }, desc => "keypair input validates" }, { argv => [ qw( --def os=amiga ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _keypair_invalid("--def","os","amiga"), desc => "value not validating" }, ] }; push @good_specs, { label => "validate w/ code refs", spec => [ Counter("--verbose|-v")->default(1), Param("--input|-i", sub { /\d+/ })->default(42), Param("--answer", sub { $_ < 43 })->default(23), ], cases => [ { argv => [ qw( ) ], result => { "verbose" => 1, "input" => 42, "answer" => 23 }, desc => "no options" }, { argv => [ qw( --input 23 ) ], result => { "verbose" => 1, "input" => 23, "answer" => 23 }, desc => "input validates" }, { argv => [ qw( --answer 60 ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _param_invalid("--answer","60"), desc => "input failing to validate" }, ] }; push @good_specs, { label => "single dependency", spec => [ Param("--question"), Switch("--guess")->needs("--answer"), Param("--answer|-a"), ], cases => [ { argv => [ qw( --question 5 ) ], result => { "question" => 5, "guess" => 0, "answer" => undef }, desc => "single, unrelated option" }, { argv => [ qw( --guess ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _prereq_missing("--guess", "--answer"), desc => "missing prereq" }, { argv => [ qw( --guess --answer 3 ) ], result => { "question" => undef, "guess" => 1, "answer" => "3" }, desc => "prereq present" }, { argv => [ qw( --guess -a 3 ) ], result => { "question" => undef, "guess" => 1, "answer" => "3" }, desc => "prereq present as alias" }, ] }; push @good_specs, { label => "multiple dependencies", spec => [ Switch("--guess")->needs(qw( --answer --wager )), Param("--wager|-w"), Param("--answer|-a"), ], cases => [ { argv => [ qw( ) ], result => { "guess" => 0, "answer" => undef, wager => undef }, desc => "no options" }, { argv => [ qw( --guess ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _prereq_missing("--guess", "--answer"), desc => "missing both prereqs" }, { argv => [ qw( --guess --answer 5 ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _prereq_missing("--guess", "--wager"), desc => "missing one prereq" }, { argv => [ qw( --guess --answer 3 --wager 10 ) ], result => { "guess" => 1, "answer" => 3, "wager" => 10 }, desc => "prereq present" }, ] }; push @good_specs, { label => "single dependency with alias", spec => [ Param("--question"), Switch("--guess")->needs("-a"), Param("--answer|-a"), ], cases => [ { argv => [ qw( --guess ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _prereq_missing("--guess", "--answer"), desc => "missing prereq" }, { argv => [ qw( --guess --answer 3 ) ], result => { "question" => undef, "guess" => 1, "answer" => "3" }, desc => "prereq present" }, { argv => [ qw( --guess -a 3 ) ], result => { "question" => undef, "guess" => 1, "answer" => "3" }, desc => "prereq present as alias" }, ] }; push @good_specs, { label => "dash and underscore options", spec => [ Switch("--dash-style"), Switch("--underscore_style"), ], cases => [ { argv => [ qw( --dash-style ) ], result => { "dash-style" => "1", "underscore_style" => "0" }, desc => "dash-style name works", }, { argv => [ qw( --underscore_style ) ], result => { "dash-style" => "0", "underscore_style" => "1" }, desc => "underscore_style name works", }, ] }; push @good_specs, { label => "Null Param,List,Keypair", spec => [ Param("--param"), List("--list"), Keypair("--key-pair"), ], cases => [ { argv => [ qw( --param ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _no_value("--param"), desc => "parameter with no value", }, { argv => [ qw( --list ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _no_value("--list"), desc => "list with no value", }, { argv => [ qw( --key-pair ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _no_value("--key-pair"), desc => "keypair with no value", }, ] }; # Bad specification testing push @bad_specs, { spec => [ Switch("-v|--verbose"), Switch("--verbose"), ], exception => "Getopt::Lucid::Exception::Spec", error_msg => _name_not_unique("--verbose"), label => "duplicate name and alias in spec" }; push @bad_specs, { spec => [ Switch("--quick|-q"), Switch("--quiet|-q"), ], exception => "Getopt::Lucid::Exception::Spec", error_msg => _name_not_unique("-q"), label => "duplicate aliases in spec" }; push @bad_specs, { spec => [ Switch("--quick"), Switch("quick"), ], exception => "Getopt::Lucid::Exception::Spec", error_msg => _name_not_unique("quick"), label => "duplicate name bareword and long" }; push @bad_specs, { spec => [ Switch("-vv"), ], exception => "Getopt::Lucid::Exception::Spec", error_msg => _name_invalid("-vv"), label => "bad option name in spec - short w/ > 1 letter" }; push @bad_specs, { spec => [ Switch("--%%"), ], exception => "Getopt::Lucid::Exception::Spec", error_msg => _name_invalid("--%%"), label => "bad option name in spec - symbols" }; push @bad_specs, { spec => [ { name => "-v", badtype => "badtype" }, ], exception => "Getopt::Lucid::Exception::Spec", error_msg => _key_invalid("badtype"), label => "bad spec key" }; push @bad_specs, { spec => [ { name => "-v", type => "badtype" } ], exception => "Getopt::Lucid::Exception::Spec", error_msg => _type_invalid("badtype"), label => "bad spec type" }; push @bad_specs, { spec => [ { name => "-v", type => "alist" }, ], exception => "Getopt::Lucid::Exception::Spec", error_msg => _type_invalid("alist"), label => "bad spec type w valid substring" }; push @bad_specs, { spec => [ Keypair("-v")->default([]), ], exception => "Getopt::Lucid::Exception::Spec", error_msg => _default_keypair("-v"), label => "keypair default not hash reference" }; push @bad_specs, { spec => [ Param("-v", qr/[a-z]+/)->default(1), ], exception => "Getopt::Lucid::Exception::Spec", error_msg => _default_invalid("-v","1"), label => "provided default not validating vs regex" }; push @bad_specs, { spec => [ Switch("--guess")->needs(qw( --answer --wager )), Switch("--answer|-a"), ], exception => "Getopt::Lucid::Exception::Spec", error_msg => _unknown_prereq("--wager","--guess"), label => "unknown prereq", }; } #BEGIN $num_tests = 2 * @bad_specs; for my $t (@good_specs) { $num_tests += 1 + 2 * @{$t->{cases}}; } plan tests => $num_tests; #--------------------------------------------------------------------------# # Test good specs #--------------------------------------------------------------------------# my $trial; while ( $trial = shift @good_specs ) { try eval { Getopt::Lucid->new($trial->{spec}) }; catch my $err; is( $err, undef, "$trial->{label}: spec should validate" ); SKIP: { if ($err) { my $num_tests = 2 * @{$trial->{cases}}; skip "because $trial->{label} spec did not validate", $num_tests; } for my $case ( @{$trial->{cases}} ) { my $gl = Getopt::Lucid->new($trial->{spec}); @ARGV = @{$case->{argv}}; my %opts; my $valid_args = $case->{required} ? {requires => $case->{required}} : {}; try eval { %opts = $gl->getopt->validate($valid_args)->options }; catch my $err; if (defined $case->{exception}) { # expected ok( $err && $err->isa( $case->{exception} ), "$trial->{label}: $case->{desc} throws exception" ) or diag why( got => ref($err), expected => $case->{exception}); is( $err, $case->{error_msg}, "$trial->{label}: $case->{desc} error msg ok"); } elsif ($err) { # unexpected fail( "$trial->{label}: $case->{desc}") or diag "Threw exception: '$err'"; pass("$trial->{label}: skipping \@ARGV check"); } else { # no exception is_deeply( \%opts, $case->{result}, "$trial->{label}: $case->{desc}" ) or diag why( got => \%opts, expected => $case->{result}); my $argv_after = $case->{after} || []; is_deeply( \@ARGV, $argv_after, "$trial->{label}: \@ARGV correct afterwards") or diag why( got => \@ARGV, expected => $argv_after); } } } } #--------------------------------------------------------------------------# # Test bad specs #--------------------------------------------------------------------------# while ( $trial = shift @bad_specs ) { try eval { Getopt::Lucid->new($trial->{spec}) }; catch my $err; ok( $err && $err->isa( $trial->{exception} ), "$trial->{label} throws exception" ) or diag why( got => ref($err), expected => $trial->{exception}); is( $err, $trial->{error_msg}, "$trial->{label} error msg ok"); } Getopt-Lucid-1.08/t/03-getopt-notargv.t000644 000765 000024 00000006543 13074555746 020054 0ustar00davidstaff000000 000000 use strict; use Test::More; use Data::Dumper; use Exception::Class::TryCatch; use Getopt::Lucid ':all'; use Getopt::Lucid::Exception; # Work around win32 console buffering that can show diags out of order Test::More->builder->failure_output(*STDOUT) if $ENV{HARNESS_VERBOSE}; sub why { my %vars = @_; $Data::Dumper::Sortkeys = 1; return "\n" . Data::Dumper->Dump([values %vars],[keys %vars]) . "\n"; } #--------------------------------------------------------------------------# # Test cases #--------------------------------------------------------------------------# my ($num_tests, @good_specs); BEGIN { push @good_specs, { label => "parse another array than \@ARGV", spec => [ Switch("--verbose"), Switch("--test"), Switch("-r"), ], cases => [ { argv => [ qw( --verbose -r -- --test ) ], result => { "verbose" => 1, "test" => 0, "r" => 1 }, after => [ qw( --test ) ], desc => "stop after two" }, { argv => [ qw( -- -r --test ) ], result => { "verbose" => 0, "test" => 0, "r" => 0 }, after => [ qw(-r --test ) ], desc => "stop right away" }, ] }; } #BEGIN for my $t (@good_specs) { $num_tests += 1 + 2 * @{$t->{cases}}; } plan tests => $num_tests; #--------------------------------------------------------------------------# # Test good specs #--------------------------------------------------------------------------# my ($trial, @cmd_line); while ( $trial = shift @good_specs ) { try eval { Getopt::Lucid->new($trial->{spec}, \@cmd_line) }; catch my $err; is( $err, undef, "$trial->{label}: spec should validate" ); SKIP: { if ($err) { my $num_tests = 2 * @{$trial->{cases}}; skip "because $trial->{label} spec did not validate", $num_tests; } for my $case ( @{$trial->{cases}} ) { my $gl = Getopt::Lucid->new($trial->{spec}, \@cmd_line); @cmd_line = @{$case->{argv}}; my %opts; try eval { %opts = $gl->getopt->options }; catch my $err; if (defined $case->{exception}) { # expected ok( $err && $err->isa( $case->{exception} ), "$trial->{label}: $case->{desc} should throw exception" ) or diag why( got => ref($err), expected => $case->{exception}); is( $err, $case->{error_msg}, "$trial->{label}: $case->{desc} error message correct"); } elsif ($err) { # unexpected fail( "$trial->{label}: $case->{desc} threw an exception") or diag "Exception is '$err'"; pass("$trial->{label}: skipping \@ARGV check"); } else { # no exception is_deeply( \%opts, $case->{result}, "$trial->{label}: $case->{desc}" ) or diag why( got => \%opts, expected => $case->{result}); my $argv_after = $case->{after} || []; is_deeply( \@cmd_line, $argv_after, "$trial->{label}: \@cmd_line correct after processing") or diag why( got => \@cmd_line, expected => $argv_after); } } } } Getopt-Lucid-1.08/t/04-names.t000644 000765 000024 00000002046 13074555746 016172 0ustar00davidstaff000000 000000 use strict; use Test::More; use Data::Dumper; use Exception::Class::TryCatch; use Getopt::Lucid ':all'; use Getopt::Lucid::Exception; # Work around win32 console buffering that can show diags out of order Test::More->builder->failure_output(*STDOUT) if $ENV{HARNESS_VERBOSE}; sub why { my %vars = @_; $Data::Dumper::Sortkeys = 1; return "\n" . Data::Dumper->Dump([values %vars],[keys %vars]) . "\n"; } #--------------------------------------------------------------------------# # Test cases #--------------------------------------------------------------------------# my $spec = [ Switch("--ver-bose"), Switch("--test"), Switch("-r"), ]; plan tests => 2; my $gl; try eval { $gl = Getopt::Lucid->new($spec) }; catch my $err; is( $err, undef, "spec should validate" ); SKIP: { skip( "because spec did not validate", 1) if $err; my @expect = sort qw(ver-bose test r); my @got = sort $gl->names(); is_deeply( \@got, \@expect, "names() produces keywords") or diag why( got => \@got, expected => \@expect ); } Getopt-Lucid-1.08/t/05-accessors.t000644 000765 000024 00000006002 13074555746 017051 0ustar00davidstaff000000 000000 use strict; use Test::More; use Data::Dumper; use Exception::Class::TryCatch; use Getopt::Lucid ':all'; use Getopt::Lucid::Exception; # Work around win32 console buffering that can show diags out of order Test::More->builder->failure_output(*STDOUT) if $ENV{HARNESS_VERBOSE}; sub why { my %vars = @_; $Data::Dumper::Sortkeys = 1; return "\n" . Data::Dumper->Dump([values %vars],[keys %vars]) . "\n"; } #--------------------------------------------------------------------------# # Test cases #--------------------------------------------------------------------------# my $spec = [ Switch("-t"), Counter("--verb_osity"), Param("--file-name"), List("-I"), Keypair("-d"), ]; my $case = { argv => [ qw( --verb_osity -t --file-name=passwd -I /etc -I /lib -d os=linux ) ], result => { t => 1, verb_osity => 1, "file-name" => "passwd", I => [qw(/etc /lib)], d => { os => "linux" }, }, desc => "getopt accessors" }; my $replace = { t => 2, verb_osity => 3, "file-name" => "group", I => [qw(/var /tmp)], d => { os => "win32" }, }; my $num_tests = 11 ; plan tests => $num_tests ; my ($gl, @cmd_line); try eval { $gl = Getopt::Lucid->new($spec, \@cmd_line) }; catch my $err; is( $err, undef, "spec should validate" ); SKIP: { if ($err) { skip "because spec did not validate", $num_tests - 1; } @cmd_line = @{$case->{argv}}; my $expect = $case->{result}; my %opts; try eval { %opts = $gl->getopt->options }; catch my $err; if ($err) { fail( "$case->{desc} threw an exception") or diag "Exception is '$err'"; skip "because getopt failed", $num_tests - 2; } else { for my $key (keys %{$case->{result}}) { no strict 'refs'; my $result = $case->{result}{$key}; (my $clean_key = $key ) =~ s/-/_/g; if ( ref($result) eq 'ARRAY' ) { is_deeply( [eval "\$gl->get_$clean_key"], $result, "accessor for '$key' correct"); &{"Getopt::Lucid::set_$clean_key"}($gl,@{$replace->{$key}}); is_deeply( [eval "\$gl->get_$clean_key"], $replace->{$key}, "mutator for '$key' correct"); } elsif ( ref($result) eq 'HASH' ) { is_deeply( {eval "\$gl->get_$clean_key"}, $result, "accessor for '$key' correct"); &{"Getopt::Lucid::set_$clean_key"}($gl,%{$replace->{$key}}); is_deeply( {eval "\$gl->get_$clean_key"}, $replace->{$key}, "mutator for '$key' correct"); } else { is( (eval "\$gl->get_$clean_key") , $result, "accessor for '$key' correct"); &{"Getopt::Lucid::set_$clean_key"}($gl,$replace->{$key}); is( eval "\$gl->get_$clean_key", $replace->{$key}, "mutator for '$key' correct"); } } } } Getopt-Lucid-1.08/t/06-default-handling.t000644 000765 000024 00000014535 13074555746 020305 0ustar00davidstaff000000 000000 use strict; use Test::More; use Data::Dumper; use Exception::Class::TryCatch; use Getopt::Lucid ':all'; use Getopt::Lucid::Exception; use lib "."; use t::ErrorMessages; # Work around buffering that can show diags out of order Test::More->builder->failure_output(*STDOUT) if $ENV{HARNESS_VERBOSE}; sub why { my %vars = @_; $Data::Dumper::Sortkeys = 1; return "\n" . Data::Dumper->Dump([values %vars],[keys %vars]) . "\n"; } #--------------------------------------------------------------------------# # Test cases #--------------------------------------------------------------------------# my $spec = [ Switch("-t")->default(0), Counter("-v")->default(1), Param("--file-names")->default("hosts"), List("-I")->default("/home"), Keypair("-d")->default( arch => "i386" ), Switch("-x")->default(1), Param( '--undef' )->default( undef ), Param( '--empty' )->default( '' ), Param( '--no_param' )->default(), Param( '--without_default' ), ]; my $case = { argv => [ qw( -tvv -I /etc -I /lib -d version=1.0a ) ], result => { t => 1, v => 3, "file-names" => "hosts", I => [qw(/home /etc /lib)], d => { arch => "i386", version => "1.0a" }, x => 1, undef => undef, empty => '', no_param => undef, without_default => undef, }, desc => "getopt" }; my $config1 = { t => 1, v => 4, "file-names" => "group", I => [qw(/var /tmp)], d => { os => "win32" }, z => 1, # extra not in the spec undef => undef, empty => '', no_param => undef, without_default => undef, }; # package variables for easier looping by name later use vars qw( $merge_default $merge_result $append_default $append_result $replace_default $replace_result ); $merge_default = { t => 1, v => 4, "file-names" => "group", I => [qw(/var /tmp)], d => { os => "win32" }, x => 1, undef => undef, empty => '', no_param => undef, without_default => undef, }; $append_default = { t => 1, v => 5, "file-names" => "group", I => [qw(/home /var /tmp)], d => { arch => "i386", os => "win32" }, x => 1, undef => undef, empty => '', no_param => undef, without_default => undef, }; $replace_default = { t => 1, v => 4, "file-names" => "group", I => [qw(/var /tmp)], d => { os => "win32" }, x => 0, undef => undef, empty => '', no_param => undef, without_default => undef, }; $merge_result = { t => 1, v => 6, "file-names" => "group", I => [qw(/var /tmp /etc /lib)], d => { os => "win32", version => "1.0a" }, x => 1, undef => undef, empty => '', no_param => undef, without_default => undef, }; $append_result = { t => 1, v => 7, "file-names" => "group", I => [qw(/home /var /tmp /etc /lib)], d => { arch => "i386", os => "win32", version => "1.0a" }, x => 1, undef => undef, empty => '', no_param => undef, without_default => undef, }; $replace_result = { t => 1, v => 6, "file-names" => "group", I => [qw(/var /tmp /etc /lib)], d => { os => "win32", version => "1.0a" }, x => 0, undef => undef, empty => '', no_param => undef, without_default => undef, }; my $num_tests = 30 ; plan tests => $num_tests ; my ($gl, @cmd_line, $err); try eval { $gl = Getopt::Lucid->new($spec, \@cmd_line) }; catch $err; is( $err, undef, "spec should validate" ); SKIP: { if ($err) { skip "because spec did not validate", $num_tests - 1; } @cmd_line = @{$case->{argv}}; my %opts; try eval { $gl->getopt }; catch my $err; if ($err) { fail( "$case->{desc} threw an exception") or diag "Exception is '$err'"; skip "because getopt failed", $num_tests - 2; } else { my $expect = $case->{result} ; my %basic_default; for my $opt (@$spec) { local $_ = $opt->{name}; (my $strip = $_) =~ s/^-+//g; $basic_default{$strip} = (exists $opt->{default}) ? $opt->{default} : undef; } is_deeply( {$gl->defaults}, \%basic_default, "basic default options returned correctly") or diag why( got => {$gl->options}, expected => \%basic_default); is_deeply( {$gl->options}, $expect, "options with default from spec processed correctly") or diag why( got => {$gl->options}, expected => $expect); # Test things working correctly for my $fcn ( qw( merge append replace ) ) { no strict 'refs'; my $call = "${fcn}_defaults"; my ($default, $result) = map { "${fcn}_$_" } qw( default result ); for my $c ( 0 .. 1 ) { $c ? $gl->$call( %$config1 ) : $gl->$call( $config1 ); my $msg = $c ? "hash version" : "hashref version"; is_deeply( {$gl->defaults}, $$default, "$call updated defaults correctly ($msg)") or diag why( got => {$gl->defaults}, expected => $$default); is_deeply( {$gl->options}, $$result, "$call refreshed options correctly ($msg)") or diag why( got => {$gl->options}, expected => $$result); $gl->reset_defaults(); is_deeply( {$gl->options}, $expect, "options reset to spec correctly ($msg)") or diag why( got => {$gl->options}, expected => $expect); } } # Test bad args for my $fcn ( qw( merge append replace ) ) { no strict 'refs'; my $call = "${fcn}_defaults"; eval { $gl->$call ( "bad_value" ) }; catch $err; is( $err, _invalid_splat_defaults("$call()"), "$call() with invalid arguments throws exception"); eval { $gl->$call ( I => {key => "value"} ) }; catch $err; is( $err, _invalid_list("I","$call()"), "$call() with invalid list option throws exception"); eval { $gl->$call ( d => [key => "value"] ) }; catch $err; is( $err, _invalid_keypair("d","$call()"), "$call() with invalid keypair option throws exception"); } } } Getopt-Lucid-1.08/t/07-magic-names.t000644 000765 000024 00000012363 13074555746 017256 0ustar00davidstaff000000 000000 use strict; use Test::More; use Data::Dumper; use Exception::Class::TryCatch; use Getopt::Lucid ':all'; use Getopt::Lucid::Exception; use lib "."; use t::ErrorMessages; # Work around win32 console buffering that can show diags out of order Test::More->builder->failure_output(*STDOUT) if $ENV{HARNESS_VERBOSE}; sub why { my %vars = @_; $Data::Dumper::Sortkeys = 1; return "\n" . Data::Dumper->Dump([values %vars],[keys %vars]) . "\n"; } #--------------------------------------------------------------------------# # Test cases #--------------------------------------------------------------------------# my ($num_tests, @good_specs); BEGIN { push @good_specs, { label => "magic bare names in spec", spec => [ Counter("ver-bose|v"), Counter("test|t"), Counter("r"), Param("f"), ], cases => [ { argv => [ qw( --ver-bose v -rtvf=test --r test -- test ) ], result => { "ver-bose" => 3, "test" => 2, "r" => 2, "f" => "test", }, after => [qw( test )], desc => "all three types in command line" }, { argv => [ qw( --ver-bose v -rtvf fest --r test -- test ) ], result => { "ver-bose" => 3, "test" => 2, "r" => 2, "f" => "fest", }, after => [qw( test )], desc => "all three types in command line" }, { argv => [ qw( -test ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _invalid_argument("-e"), desc => "single dash with word" }, { argv => [ qw( f test ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _param_ambiguous("f", "test"), desc => "ambiguous param -- bareword" }, { argv => [ qw( f --test ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _param_ambiguous("f", "--test"), desc => "ambiguous param -- long form" }, ] }; push @good_specs, { label => "avoid ambiguity (RT 33462)", spec => [ Param("config|c"), Switch("help|h")->anycase(), ], cases => [ { argv => [ qw( -c /home/newuat5/nas/Abilit/newuat6/test_home/Data/tdg/testdatengenerator.conf ) ], required => ['config'], result => { "config" => "/home/newuat5/nas/Abilit/newuat6/test_home/Data/tdg/testdatengenerator.conf", "help" => 0, }, after => [], desc => "single dash option" }, ] }; } #BEGIN for my $t (@good_specs) { $num_tests += 1 + 2 * @{$t->{cases}}; } plan tests => $num_tests; #--------------------------------------------------------------------------# # Test good specs #--------------------------------------------------------------------------# my ($trial, @cmd_line); while ( $trial = shift @good_specs ) { try eval { Getopt::Lucid->new($trial->{spec}, \@cmd_line) }; catch my $err; is( $err, undef, "$trial->{label}: spec should validate" ); SKIP: { if ($err) { my $num_tests = 2 * @{$trial->{cases}}; skip "because $trial->{label} spec did not validate", $num_tests; } for my $case ( @{$trial->{cases}} ) { my $gl = Getopt::Lucid->new($trial->{spec}, \@cmd_line); @cmd_line = @{$case->{argv}}; my %opts; my $valid_args = $case->{required} ? {requires => $case->{required}} : {}; try eval { %opts = $gl->getopt->validate($valid_args)->options }; catch my $err; if (defined $case->{exception}) { # expected ok( $err && $err->isa( $case->{exception} ), "$trial->{label}: $case->{desc} should throw exception" ) or diag why( got => ref($err), expected => $case->{exception}); is( $err, $case->{error_msg}, "$trial->{label}: $case->{desc} error message correct"); } elsif ($err) { # unexpected fail( "$trial->{label}: $case->{desc} threw an exception") or diag "Exception is '$err'"; pass("$trial->{label}: skipping \@ARGV check"); } else { # no exception is_deeply( \%opts, $case->{result}, "$trial->{label}: $case->{desc}" ) or diag why( got => \%opts, expected => $case->{result}); my $argv_after = $case->{after} || []; is_deeply( \@cmd_line, $argv_after, "$trial->{label}: \@cmd_line correct after processing") or diag why( got => \@cmd_line, expected => $argv_after); } } } } Getopt-Lucid-1.08/t/08-strict-names.t000644 000765 000024 00000012167 13074555746 017511 0ustar00davidstaff000000 000000 use strict; use Test::More; use Data::Dumper; use Exception::Class::TryCatch; # Work around win32 console buffering that can show diags out of order Test::More->builder->failure_output(*STDOUT) if $ENV{HARNESS_VERBOSE}; use Getopt::Lucid ':all'; use Getopt::Lucid::Exception; use lib "."; use t::ErrorMessages; sub why { my %vars = @_; $Data::Dumper::Sortkeys = 1; return "\n" . Data::Dumper->Dump([values %vars],[keys %vars]) . "\n"; } #--------------------------------------------------------------------------# # Test cases #--------------------------------------------------------------------------# my ($num_tests, @good_specs); BEGIN { push @good_specs, { label => "mixed format names in spec", spec => [ Counter("ver-bose|-v"), Counter("--test|-t"), Counter("-r"), Param("f"), ], cases => [ { argv => [ qw( ver-bose -v -rtv f=test -r --test -- test ) ], result => { "ver-bose" => 3, "test" => 2, "r" => 2, "f" => "test", }, after => [qw( test )], desc => "all three types in command line" }, { argv => [ qw( ver-bose -v -rtv f test -r --test -- test ) ], result => { "ver-bose" => 3, "test" => 2, "r" => 2, "f" => "test", }, after => [qw( test )], desc => "bare param with bare like long-form in spec" }, { argv => [ qw( ver-bose -v -rtv f=test -r test ) ], result => { "ver-bose" => 3, "test" => 1, "r" => 2, "f" => "test", }, after => [qw( test )], desc => "bareword like long-form in spec passed through" }, { argv => [ qw( -test ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _invalid_argument("-e"), desc => "single dash with word" }, { argv => [ qw( --ver-bose ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _invalid_argument("--ver-bose"), desc => "long form like bareword in spec" }, { argv => [ qw( --r ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _invalid_argument("--r"), desc => "long form like short in spec" }, { argv => [ qw( -f=--test ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _invalid_argument("-f"), desc => "shoft form like bare in spec" }, ] }; } #BEGIN for my $t (@good_specs) { $num_tests += 1 + 2 * @{$t->{cases}}; } plan tests => $num_tests; #--------------------------------------------------------------------------# # Test good specs #--------------------------------------------------------------------------# my ($trial, @cmd_line); while ( $trial = shift @good_specs ) { try eval { Getopt::Lucid->new($trial->{spec}, \@cmd_line, {strict => 1}) }; catch my $err; is( $err, undef, "$trial->{label}: spec should validate" ); SKIP: { if ($err) { my $num_tests = 2 * @{$trial->{cases}}; skip "because $trial->{label} spec did not validate", $num_tests; } for my $case ( @{$trial->{cases}} ) { my $gl = Getopt::Lucid->new($trial->{spec}, \@cmd_line, {strict => 1}); @cmd_line = @{$case->{argv}}; my %opts; try eval { %opts = $gl->getopt->options }; catch my $err; if (defined $case->{exception}) { # expected ok( $err && $err->isa( $case->{exception} ), "$trial->{label}: $case->{desc} should throw exception" ) or diag why( got => ref($err), expected => $case->{exception}); is( $err, $case->{error_msg}, "$trial->{label}: $case->{desc} error message correct"); } elsif ($err) { # unexpected fail( "$trial->{label}: $case->{desc} threw an exception") or diag "Exception is '$err'"; pass("$trial->{label}: skipping \@ARGV check"); } else { # no exception is_deeply( \%opts, $case->{result}, "$trial->{label}: $case->{desc}" ) or diag why( got => \%opts, expected => $case->{result}); my $argv_after = $case->{after} || []; is_deeply( \@cmd_line, $argv_after, "$trial->{label}: \@cmd_line correct after processing") or diag why( got => \@cmd_line, expected => $argv_after); } } } } Getopt-Lucid-1.08/t/09-negation.t000644 000765 000024 00000016432 13074555746 016704 0ustar00davidstaff000000 000000 use strict; use Test::More; use Data::Dumper; use Exception::Class::TryCatch; use Getopt::Lucid ':all'; use Getopt::Lucid::Exception; use lib "."; use t::ErrorMessages; # Work around win32 console buffering that can show diags out of order Test::More->builder->failure_output(*STDOUT) if $ENV{HARNESS_VERBOSE}; sub why { my %vars = @_; $Data::Dumper::Sortkeys = 1; return "\n" . Data::Dumper->Dump([values %vars],[keys %vars]) . "\n"; } #--------------------------------------------------------------------------# # Test cases #--------------------------------------------------------------------------# my ($num_tests, @good_specs); BEGIN { push @good_specs, { label => "negation test", spec => [ Switch("test|t")->default(1), Counter("ver-bose|v")->default(2), Param("file|f")->default("foo.txt"), List("lib|l")->default(qw( /var /tmp )), Keypair("def|d")->default({os => 'linux', arch => 'i386'}), ], cases => [ { argv => [ qw( --no-test --no-ver-bose --no-file --no-lib --no-def ) ], result => { "test" => 0, "ver-bose" => 0, "file" => "", "lib" => [], "def" => {}, }, desc => "long-form negate everything" }, { argv => [ qw( no-test no-ver-bose no-file no-lib no-def ) ], result => { "test" => 0, "ver-bose" => 0, "file" => "", "lib" => [], "def" => {}, }, desc => "bareword-form negate everything" }, { argv => [ qw( no-lib=/var --no-def=os ) ], result => { "test" => 1, "ver-bose" => 2, "file" => "foo.txt", "lib" => [qw( /tmp )], "def" => { arch => "i386" }, }, desc => "negate list item and keypair key" }, { argv => [ qw( no-test no-ver-bose no-file no-lib=/var --no-def=os --test --ver-bose --file boo.txt --lib /home --def flag=O2) ], result => { "test" => 1, "ver-bose" => 1, "file" => "boo.txt", "lib" => [qw( /tmp /home )], "def" => { arch => "i386", flag => "O2" }, }, desc => "negate followed by new options" }, { argv => [ qw( no-test=1 ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _switch_value("test","1"), desc => "negative switch can't take value" }, { argv => [ qw( no-ver-bose=1 ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _counter_value("ver-bose","1"), desc => "negative counter can't take value" }, { argv => [ qw( no-file=foo.txt ) ], exception => "Getopt::Lucid::Exception::ARGV", error_msg => _param_neg_value("file","foo.txt"), desc => "negative param can't take value" }, ] }; push @good_specs, { label => "negation w/ validation", spec => [ Param( "mode|m", qr/test|live/ ) ], cases => [ { argv => [ qw() ], result => { "mode" => undef, }, desc => "no param validates" }, { argv => [ qw( --no-mode ) ], result => { "mode" => '', }, desc => "negated param validates" }, ] }; push @good_specs, { label => "required/prereq", spec => [ Switch("test"), Param("input")->needs("output"), Param("output"), ], cases => [ { argv => [ qw( --test --no-test ) ], exception => "Getopt::Lucid::Exception::ARGV", required => ['test'], error_msg => _required("test"), desc => "missing requirement after negation" }, { argv => [ qw( --test --input in.txt --output out.txt --no-output ) ], exception => "Getopt::Lucid::Exception::ARGV", required => ['test'], error_msg => _prereq_missing("input","output",), desc => "missing prereq after negation" }, ], }; } #BEGIN for my $t (@good_specs) { $num_tests += 1 + 2 * @{$t->{cases}}; } plan tests => $num_tests; #--------------------------------------------------------------------------# # Test good specs #--------------------------------------------------------------------------# my ($trial, @cmd_line); while ( $trial = shift @good_specs ) { try eval { Getopt::Lucid->new($trial->{spec}, \@cmd_line) }; catch my $err; is( $err, undef, "$trial->{label}: spec should validate" ); SKIP: { if ($err) { my $num_tests = 2 * @{$trial->{cases}}; skip "because $trial->{label} spec did not validate", $num_tests; } for my $case ( @{$trial->{cases}} ) { my $gl = Getopt::Lucid->new($trial->{spec}, \@cmd_line); @cmd_line = @{$case->{argv}}; my %opts; my $valid_args = $case->{required} ? {requires => $case->{required}} : {}; try eval { %opts = $gl->getopt->validate($valid_args)->options }; catch my $err; if (defined $case->{exception}) { # expected ok( $err && $err->isa( $case->{exception} ), "$trial->{label}: $case->{desc} should throw exception" ) or diag why( got => ref($err), expected => $case->{exception}); is( $err, $case->{error_msg}, "$trial->{label}: $case->{desc} error message correct"); } elsif ($err) { # unexpected fail( "$trial->{label}: $case->{desc} threw an exception") or diag "Exception is '$err'"; pass("$trial->{label}: skipping \@ARGV check"); } else { # no exception is_deeply( \%opts, $case->{result}, "$trial->{label}: $case->{desc}" ) or diag why( got => \%opts, expected => $case->{result}); my $argv_after = $case->{after} || []; is_deeply( \@cmd_line, $argv_after, "$trial->{label}: \@cmd_line correct after processing") or diag why( got => \@cmd_line, expected => $argv_after); } } } } Getopt-Lucid-1.08/t/10-default-validation.t000644 000765 000024 00000016160 13074555746 020642 0ustar00davidstaff000000 000000 use strict; use Test::More; use Data::Dumper; use Exception::Class::TryCatch; use Getopt::Lucid ':all'; use Getopt::Lucid::Exception; use lib "."; use t::ErrorMessages; # Work around win32 console buffering that can show diags out of order Test::More->builder->failure_output(*STDOUT) if $ENV{HARNESS_VERBOSE}; sub why { my %vars = @_; $Data::Dumper::Sortkeys = 1; return "\n" . Data::Dumper->Dump([values %vars],[keys %vars]) . "\n"; } #--------------------------------------------------------------------------# # Test cases #--------------------------------------------------------------------------# my ($num_tests, @good_specs); push @good_specs, { label => "test", spec => [ Switch("test|t")->default(1), Counter("verbose|v")->default(2), Param("file|f")->valid(qr/[a-z]+/)->default("foo"), List("lib|l")->default(qw( /var /tmp ))->valid(qr/[\/\w]+/), Keypair("def|d","os|arch",qr/\w+/)->default( {os => 'linux', arch => 'i386'} ), ], cases => [ { desc => "no args, no config", argv => [ ], config => undef, result => { append => { "test" => 1, "verbose" => 2, "file" => "foo", "lib" => [qw( /var /tmp )], "def" => {os => 'linux', arch => 'i386'}, }, merge => { "test" => 1, "verbose" => 2, "file" => "foo", "lib" => [qw( /var /tmp )], "def" => {os => 'linux', arch => 'i386'}, }, replace => { "test" => 1, "verbose" => 2, "file" => "foo", "lib" => [qw( /var /tmp )], "def" => {os => 'linux', arch => 'i386'}, }, }, }, { desc => "no args, valid config", argv => [ ], config => { "verbose" => 1, "file" => "bar", "lib" => "/home", "def" => { os => 'MSWin32' }, }, result => { append => { "test" => 1, "verbose" => 3, "file" => "bar", "lib" => [qw( /var /tmp /home )], "def" => { os => 'MSWin32', arch => 'i386'}, }, merge => { "test" => 1, "verbose" => 1, "file" => "bar", "lib" => [qw( /home )], "def" => { os => 'MSWin32' }, }, replace => { "test" => 0, "verbose" => 1, "file" => "bar", "lib" => [qw( /home )], "def" => { os => 'MSWin32' }, }, }, }, { desc => "args plus valid config", argv => [ qw/--def arch=amd64 / ], config => { "verbose" => 1, "file" => "bar", "lib" => "/home", "def" => { os => 'MSWin32' }, }, result => { append => { "test" => 1, "verbose" => 3, "file" => "bar", "lib" => [qw( /var /tmp /home )], "def" => { os => 'MSWin32', arch => 'amd64'}, }, merge => { "test" => 1, "verbose" => 1, "file" => "bar", "lib" => [qw( /home )], "def" => { os => 'MSWin32', arch => 'amd64' }, }, replace => { "test" => 0, "verbose" => 1, "file" => "bar", "lib" => [qw( /home )], "def" => { os => 'MSWin32', arch => 'amd64' }, }, }, }, { argv => [ ], exception => "Getopt::Lucid::Exception::Spec", config => { "file" => "123", }, error_msg => _default_invalid("file","123",), desc => "invalid config" }, ] }; for my $t (@good_specs) { $num_tests += 1 + 6 * @{$t->{cases}}; } plan tests => $num_tests; #--------------------------------------------------------------------------# # Test good specs #--------------------------------------------------------------------------# my ($trial, @cmd_line); while ( $trial = shift @good_specs ) { try eval { Getopt::Lucid->new($trial->{spec}, \@cmd_line) }; catch my $err; is( $err, undef, "$trial->{label}: spec should validate" ); SKIP: { if ($err) { my $num_tests = 6 * @{$trial->{cases}}; skip "because $trial->{label} spec did not validate", $num_tests; } for my $case ( @{$trial->{cases}} ) { for my $method ( qw/append merge replace/ ) { no strict 'refs'; my $cmd = $method . "_defaults"; my $gl = Getopt::Lucid->new($trial->{spec}, \@cmd_line); @cmd_line = @{$case->{argv}}; try eval { $gl->getopt; $gl->$cmd( $case->{config} ) if $case->{config}; }; catch my $err; if (defined $case->{exception}) { # expected ok( $err && $err->isa( $case->{exception} ), "$trial->{label} $method\_defaults\: $case->{desc} should throw exception" ) or diag why( got => ref($err), expected => $case->{exception}); is( $err, $case->{error_msg}, "$trial->{label} $method\_defaults\: $case->{desc} error message correct"); } elsif ($err) { # unexpected fail( "$trial->{label} $method\_defaults\: $case->{desc} threw an exception") or diag "Exception is '$err'"; pass("$trial->{label} $method\_defaults\: skipping \@ARGV check"); } else { # no exception my %opts = $gl->options; is_deeply( \%opts, $case->{result}{$method}, "$trial->{label} $method\_defaults\: $case->{desc}" ) or diag why( got => \%opts, expected => $case->{result}{$method}); my $argv_after = $case->{after} || []; is_deeply( \@cmd_line, $argv_after, "$trial->{label} $method\_defaults\: \@cmd_line correct after processing") or diag why( got => \@cmd_line, expected => $argv_after); } } } } } Getopt-Lucid-1.08/t/ErrorMessages.pm000644 000765 000024 00000004303 13074555746 017576 0ustar00davidstaff000000 000000 package t::ErrorMessages; @ISA = ("Exporter"); use strict; use Exporter (); sub _invalid_argument {sprintf("Invalid argument: %s\n",@_)} sub _required {sprintf("Required option '%s' not found\n",@_)} sub _switch_twice {sprintf("Switch used twice: %s\n",@_)} sub _switch_value {sprintf("Switch can't take a value: %s=%s\n",@_)} sub _counter_value {sprintf("Counter option can't take a value: %s=%s\n",@_)} sub _param_ambiguous {sprintf("Ambiguous value for %s could be option: %s\n",@_)} sub _param_invalid {sprintf("Invalid parameter %s = %s\n",@_)} sub _param_neg_value {sprintf("Negated parameter option can't take a value: %s=%s\n",@_)} sub _list_invalid {sprintf("Invalid list option %s = %s\n",@_)} sub _keypair_invalid {sprintf("Invalid keypair '%s': %s => %s\n",@_)} sub _list_ambiguous {sprintf("Ambiguous value for %s could be option: %s\n",@_)} sub _keypair {sprintf("Badly formed keypair for '%s'\n",@_)} sub _default_list {sprintf("Default for list '%s' must be array reference\n",@_)} sub _default_keypair {sprintf("Default for keypair '%s' must be hash reference\n",@_)} sub _default_invalid {sprintf("Default '%s' = '%s' fails to validate\n",@_)} sub _name_invalid {sprintf("'%s' is not a valid option name/alias\n",@_)} sub _name_not_unique {sprintf("'%s' is not unique\n",@_)} sub _name_conflicts {sprintf("'%s' conflicts with other options\n",@_)} sub _key_invalid {sprintf("'%s' is not a valid option specification key\n",@_)} sub _type_invalid {sprintf("'%s' is not a valid option type\n",@_)} sub _prereq_missing {sprintf("Option '%s' requires option '%s'\n",@_)} sub _unknown_prereq {sprintf("Prerequisite '%s' for '%s' is not recognized\n",@_)} sub _invalid_list {sprintf("Option '%s' in %s must be scalar or array reference\n",@_)} sub _invalid_keypair {sprintf("Option '%s' in %s must be scalar or hash reference\n",@_)} sub _invalid_splat_defaults {sprintf("Argument to %s must be a hash or hash reference\n",@_)} sub _no_value {sprintf("Option '%s' requires a value\n",@_)} # keep this last; for (keys %t::ErrorMessages::) { push @t::ErrorMessages::EXPORT, $_ if $_ =~ "^_"; } 1; Getopt-Lucid-1.08/lib/Getopt/000755 000765 000024 00000000000 13074555746 016224 5ustar00davidstaff000000 000000 Getopt-Lucid-1.08/lib/Getopt/Lucid/000755 000765 000024 00000000000 13074555746 017264 5ustar00davidstaff000000 000000 Getopt-Lucid-1.08/lib/Getopt/Lucid.pm000644 000765 000024 00000150270 13074555746 017627 0ustar00davidstaff000000 000000 use 5.006; use strict; use warnings; package Getopt::Lucid; # ABSTRACT: Clear, readable syntax for command line processing our $VERSION = '1.08'; our @EXPORT_OK = qw(Switch Counter Param List Keypair); our %EXPORT_TAGS = ( all => [ @EXPORT_OK ] ); our @ISA = qw( Exporter ); use Carp; use Exporter (); use Getopt::Lucid::Exception; use Storable 2.16 qw(dclone); # Definitions my $VALID_STARTCHAR = "a-zA-Z0-9"; my $VALID_CHAR = "a-zA-Z0-9_-"; my $VALID_LONG = qr/--[$VALID_STARTCHAR][$VALID_CHAR]*/; my $VALID_SHORT = qr/-[$VALID_STARTCHAR]/; my $VALID_BARE = qr/[$VALID_STARTCHAR][$VALID_CHAR]*/; my $VALID_NAME = qr/$VALID_LONG|$VALID_SHORT|$VALID_BARE/; my $SHORT_BUNDLE = qr/-[$VALID_STARTCHAR]{2,}/; my $NEGATIVE = qr/(?:--)?no-/; my @valid_keys = qw( name type default nocase valid needs canon ); my @valid_types = qw( switch counter parameter list keypair); sub Switch { return bless { name => shift, type => 'switch' }, "Getopt::Lucid::Spec"; } sub Counter { return bless { name => shift, type => 'counter' }, "Getopt::Lucid::Spec"; } sub Param { my $self = { name => shift, type => 'parameter' }; $self->{valid} = shift if @_; return bless $self, "Getopt::Lucid::Spec"; } sub List { my $self = { name => shift, type => 'list' }; $self->{valid} = shift if @_; return bless $self, "Getopt::Lucid::Spec"; } sub Keypair { my $self = { name => shift, type => 'keypair' }; $self->{valid} = [ @_ ] if scalar @_; return bless $self, "Getopt::Lucid::Spec"; } package Getopt::Lucid::Spec; $Getopt::Lucid::Spec::VERSION = $Getopt::Lucid::VERSION; # alternate way to specify validation sub valid { my $self = shift; Getopt::Lucid::throw_spec("valid() is not supported for '$self->{type}' options") unless grep { $self->{type} eq $_ } qw/parameter list keypair/; $self->{valid} = $self->{type} eq 'keypair' ? [ @_ ] : shift; return $self; } sub default { my $self = shift; my $type = $self->{type}; if ($self->{type} eq 'keypair') { if (ref($_[0]) eq 'HASH') { $self->{default} = shift; } elsif ( @_ % 2 == 0 ) { $self->{default} = { @_ }; } else { $self->{default} = []; # will cause an exception later } } elsif ( $self->{type} eq 'list' ) { $self->{default} = [ @_ ]; } else { $self->{default} = shift; } return $self }; sub anycase { my $self = shift; $self->{nocase}=1; return $self }; sub needs { my $self = shift; $self->{needs}=[@_]; return $self }; package Getopt::Lucid; #--------------------------------------------------------------------------# # new() #--------------------------------------------------------------------------# my @params = qw/strict target/; sub new { my ($class, $spec, $target) = @_; my $args = ref($_[-1]) eq 'HASH' ? pop(@_) : {}; $args->{target} = ref($target) eq 'ARRAY' ? $target : \@ARGV; my $self = {}; $self->{$_} = $args->{$_} for @params; $self->{raw_spec} = $spec; bless ($self, ref($class) ? ref($class) : $class); throw_usage("Getopt::Lucid->new() requires an option specification array reference") unless ref($self->{raw_spec}) eq 'ARRAY'; _parse_spec($self); _set_defaults($self); $self->{options} = {}; $self->{parsed} = []; $self->{seen}{$_} = 0 for keys %{$self->{spec}}; return $self; } #--------------------------------------------------------------------------# # append_defaults() #--------------------------------------------------------------------------# sub append_defaults { my $self = shift; my %append = ref $_[0] eq 'HASH' ? %{+shift} : (@_ % 2 == 0) ? @_ : throw_usage("Argument to append_defaults() must be a hash or hash reference"); for my $name ( keys %{$self->{spec}} ) { my $spec = $self->{spec}{$name}; my $strip = $self->{strip}{$name}; next unless exists $append{$strip}; for ( $spec->{type} ) { /switch|parameter/ && do { $self->{default}{$strip} = $append{$strip}; last; }; /counter/ && do { $self->{default}{$strip} += $append{$strip}; last; }; /list/ && do { throw_usage("Option '$strip' in append_defaults() must be scalar or array reference") if ref($append{$strip}) && ref($append{$strip}) ne 'ARRAY'; $append{$strip} = ref($append{$strip}) eq 'ARRAY' ? dclone( $append{$strip} ) : [ $append{$strip} ] ; push @{$self->{default}{$strip}}, @{$append{$strip}}; last; }; /keypair/ && do { throw_usage("Option '$strip' in append_defaults() must be scalar or hash reference") if ref($append{$strip}) && ref($append{$strip}) ne 'HASH'; $self->{default}{$strip} = { %{$self->{default}{$strip}}, %{$append{$strip}}, }; last; }; } throw_spec("Default '$spec->{canon}' = '$self->{default}{$strip}' fails to validate") unless _validate_value($self, $self->{default}{$strip}, $spec->{valid} ); } _recalculate_options($self); return $self->options; } #--------------------------------------------------------------------------# # defaults() #--------------------------------------------------------------------------# sub defaults { my ($self) = @_; return %{dclone($self->{default})}; } #--------------------------------------------------------------------------# # getopt() #--------------------------------------------------------------------------# sub getopt { my ($self,$spec,$target) = @_; if ( $self eq 'Getopt::Lucid' ) { throw_usage("Getopt::Lucid->getopt() requires an option specification array reference") unless ref($spec) eq 'ARRAY'; $self = new(@_) } my (@passthrough); while (@{$self->{target}}) { my $raw = shift @{$self->{target}}; last if $raw =~ /^--$/; my ($orig, $val) = _split_equals($self, $raw); next if _unbundle($self, $orig, $val); my $neg = $orig =~ s/^$NEGATIVE(.*)$/$1/ ? 1 : 0; my $arg = _find_arg($self, $orig); if ( $arg ) { $neg ? $self->{seen}{$arg} = 0 : $self->{seen}{$arg}++; for ($self->{spec}{$arg}{type}) { /switch/ ? _switch ($self, $arg, $val, $neg) : /counter/ ? _counter ($self, $arg, $val, $neg) : /parameter/ ? _parameter($self, $arg, $val, $neg) : /list/ ? _list ($self, $arg, $val, $neg) : /keypair/ ? _keypair ($self, $arg, $val, $neg) : throw_usage("can't handle type '$_'"); } } else { throw_argv("Invalid argument: $orig") if $orig =~ /^-./; # invalid if looks like it could be an arg; push @passthrough, $orig; } } _recalculate_options($self); @{$self->{target}} = (@passthrough, @{$self->{target}}); return $self; } BEGIN { *getopts = \&getopt }; # handy alias #--------------------------------------------------------------------------# # validate #--------------------------------------------------------------------------# sub validate { my ($self, $arg) = @_; throw_usage("Getopt::Lucid->validate() takes a hashref argument") if $arg && ref($arg) ne 'HASH'; if ( $arg && exists $arg->{requires} ) { my $requires = $arg->{requires}; throw_usage("'validate' argument 'requires' must be an array reference") if $requires && ref($requires) ne 'ARRAY'; for my $p ( @$requires ) { throw_argv("Required option '$self->{spec}{$p}{canon}' not found") if ( ! $self->{seen}{$p} ); } } _check_prereqs($self); return $self; } #--------------------------------------------------------------------------# # merge_defaults() #--------------------------------------------------------------------------# sub merge_defaults { my $self = shift; my %merge = ref $_[0] eq 'HASH' ? %{+shift} : (@_ % 2 == 0) ? @_ : throw_usage("Argument to merge_defaults() must be a hash or hash reference"); for my $name ( keys %{$self->{spec}} ) { my $spec = $self->{spec}{$name}; my $strip = $self->{strip}{$name}; next unless exists $merge{$strip}; for ( $self->{spec}{$name}{type} ) { /switch|counter|parameter/ && do { $self->{default}{$strip} = $merge{$strip}; last; }; /list/ && do { throw_usage("Option '$strip' in merge_defaults() must be scalar or array reference") if ref($merge{$strip}) && ref($merge{$strip}) ne 'ARRAY'; $merge{$strip} = ref($merge{$strip}) eq 'ARRAY' ? dclone( $merge{$strip} ) : [ $merge{$strip} ] ; $self->{default}{$strip} = $merge{$strip}; last; }; /keypair/ && do { throw_usage("Option '$strip' in merge_defaults() must be scalar or hash reference") if ref($merge{$strip}) && ref($merge{$strip}) ne 'HASH'; $self->{default}{$strip} = dclone($merge{$strip}); last; }; } throw_spec("Default '$spec->{canon}' = '$self->{default}{$strip}' fails to validate") unless _validate_value($self, $self->{default}{$strip}, $spec->{valid} ); } _recalculate_options($self); return $self->options; } #--------------------------------------------------------------------------# # names() #--------------------------------------------------------------------------# sub names { my ($self) = @_; return values %{$self->{strip}}; } #--------------------------------------------------------------------------# # options() #--------------------------------------------------------------------------# sub options { my ($self) = @_; return %{dclone($self->{options})}; } #--------------------------------------------------------------------------# # replace_defaults() #--------------------------------------------------------------------------# sub replace_defaults { my $self = shift; my %replace = ref $_[0] eq 'HASH' ? %{+shift} : (@_ % 2 == 0) ? @_ : throw_usage("Argument to replace_defaults() must be a hash or hash reference"); for my $name ( keys %{$self->{spec}} ) { my $spec = $self->{spec}{$name}; my $strip = $self->{strip}{$name}; for ( $self->{spec}{$name}{type} ) { /switch|counter/ && do { $self->{default}{$strip} = $replace{$strip} || 0; last; }; /parameter/ && do { $self->{default}{$strip} = $replace{$strip}; last; }; /list/ && do { throw_usage("Option '$strip' in replace_defaults() must be scalar or array reference") if ref($replace{$strip}) && ref($replace{$strip}) ne 'ARRAY'; if ( exists $replace{$strip} ) { $replace{$strip} = ref($replace{$strip}) eq 'ARRAY' ? $replace{$strip} : [ $replace{$strip} ]; } else { $replace{$strip} = []; } $self->{default}{$strip} = dclone($replace{$strip}); last; }; /keypair/ && do { throw_usage("Option '$strip' in replace_defaults() must be scalar or hash reference") if ref($replace{$strip}) && ref($replace{$strip}) ne 'HASH'; $replace{$strip} = {} unless exists $replace{$strip}; $self->{default}{$strip} = dclone($replace{$strip}); last; }; } throw_spec("Default '$spec->{canon}' = '$self->{default}{$strip}' fails to validate") unless _validate_value($self, $self->{default}{$strip}, $spec->{valid} ); } _recalculate_options($self); return $self->options; } #--------------------------------------------------------------------------# # reset_defaults() #--------------------------------------------------------------------------# sub reset_defaults { my ($self) = @_; _set_defaults($self); _recalculate_options($self); return $self->options; } #--------------------------------------------------------------------------# # _check_prereqs() #--------------------------------------------------------------------------# sub _check_prereqs { my ($self) = @_; for my $key ( keys %{$self->{seen}} ) { next unless $self->{seen}{$key}; next unless exists $self->{spec}{$key}{needs}; for (@{$self->{spec}{$key}{needs}}) { throw_argv("Option '$self->{spec}{$key}{canon}' ". "requires option '$self->{spec}{$_}{canon}'") unless $self->{seen}{$_}; } } } #--------------------------------------------------------------------------# # _counter() #--------------------------------------------------------------------------# sub _counter { my ($self, $arg, $val, $neg) = @_; throw_argv("Counter option can't take a value: $self->{spec}{$arg}{canon}=$val") if defined $val; push @{$self->{parsed}}, [ $arg, 1, $neg ]; } #--------------------------------------------------------------------------# # _find_arg() #--------------------------------------------------------------------------# sub _find_arg { my ($self, $arg) = @_; $arg =~ s/^-*// unless $self->{strict}; return $self->{alias_hr}{$arg} if exists $self->{alias_hr}{$arg}; for ( keys %{$self->{alias_nocase}} ) { return $self->{alias_nocase}{$_} if $arg =~ /^$_$/i; } return; } #--------------------------------------------------------------------------# # _keypair() #--------------------------------------------------------------------------# sub _keypair { my ($self, $arg, $val, $neg) = @_; my ($key, $data); if ($neg) { $key = $val; } else { my $value = defined $val ? $val : shift @{$self->{target}}; if (! defined $val && ! defined $value) { throw_argv("Option '$self->{spec}{$arg}{canon}' requires a value"); } throw_argv("Badly formed keypair for '$self->{spec}{$arg}{canon}'") unless $value =~ /[^=]+=.+/; ($key, $data) = ( $value =~ /^([^=]*)=(.*)$/ ) ; throw_argv("Invalid keypair '$self->{spec}{$arg}{canon}': $key => $data") unless _validate_value($self, { $key => $data }, $self->{spec}{$arg}{valid}); } push @{$self->{parsed}}, [ $arg, [ $key, $data ], $neg ]; } #--------------------------------------------------------------------------# # _list() #--------------------------------------------------------------------------# sub _list { my ($self, $arg, $val, $neg) = @_; my $value; if ($neg) { $value = $val; } else { $value = defined $val ? $val : shift @{$self->{target}}; if (! defined $val) { if (! defined $value) { throw_argv("Option '$self->{spec}{$arg}{canon}' requires a value"); } $value =~ s/^$NEGATIVE(.*)$/$1/; } throw_argv("Ambiguous value for $self->{spec}{$arg}{canon} could be option: $value") if ! defined $val and _find_arg($self, $value); throw_argv("Invalid list option $self->{spec}{$arg}{canon} = $value") unless _validate_value($self, $value, $self->{spec}{$arg}{valid}); } push @{$self->{parsed}}, [ $arg, $value, $neg ]; } #--------------------------------------------------------------------------# # _parameter() #--------------------------------------------------------------------------# sub _parameter { my ($self, $arg, $val, $neg) = @_; my $value; if ($neg) { throw_argv("Negated parameter option can't take a value: $self->{spec}{$arg}{canon}=$val") if defined $val; } else { $value = defined $val ? $val : shift @{$self->{target}}; if (! defined $val) { if (! defined $value) { throw_argv("Option '$self->{spec}{$arg}{canon}' requires a value"); } $value =~ s/^$NEGATIVE(.*)$/$1/; } throw_argv("Ambiguous value for $self->{spec}{$arg}{canon} could be option: $value") if ! defined $val and _find_arg($self, $value); throw_argv("Invalid parameter $self->{spec}{$arg}{canon} = $value") unless _validate_value($self, $value, $self->{spec}{$arg}{valid}); } push @{$self->{parsed}}, [ $arg, $value, $neg ]; } #--------------------------------------------------------------------------# # _parse_spec() #--------------------------------------------------------------------------# sub _parse_spec { my ($self) = @_; my $spec = $self->{raw_spec}; for my $opt ( @$spec ) { my $name = $opt->{name}; my @names = split( /\|/, $name ); $opt->{canon} = $names[0]; _validate_spec($self,\@names,$opt); @names = map { s/^-*//; $_ } @names unless $self->{strict}; ## no critic for (@names) { $self->{alias_hr}{$_} = $names[0]; $self->{alias_nocase}{$_} = $names[0] if $opt->{nocase}; } $self->{spec}{$names[0]} = $opt; ($self->{strip}{$names[0]} = $names[0]) =~ s/^-+//; } _validate_prereqs($self); } #--------------------------------------------------------------------------# # _recalculate_options() #--------------------------------------------------------------------------# sub _recalculate_options { my ($self) = @_; my %result; for my $k ( keys %{$self->{default}} ) { my $d = $self->{default}{$k}; $result{$k} = ref($d) eq 'ARRAY' ? [ @$d ] : ref($d) eq 'HASH' ? { %$d } : $d; } for my $opt ( @{$self->{parsed}} ) { my ($name, $value, $neg) = @$opt; for ($self->{spec}{$name}{type}) { my $strip = $self->{strip}{$name}; /switch/ && do { $result{$strip} = $neg ? 0 : $value; last; }; /counter/ && do { $result{$strip} = $neg ? 0 : $result{$strip} + $value; last; }; /parameter/ && do { $result{$strip} = $neg ? "" : $value; last; }; /list/ && do { if ($neg) { $result{$strip} = $value ? [ grep { $_ ne $value } @{$result{$strip}} ] : []; } else { push @{$result{$strip}}, $value } last; }; /keypair/ && do { if ($neg) { if ($value->[0]) { delete $result{$strip}{$value->[0]} } else { $result{$strip} = {} } } else { $result{$strip}{$value->[0]} = $value->[1]}; last; }; } } return $self->{options} = \%result; } #--------------------------------------------------------------------------# # _regex_or_code #--------------------------------------------------------------------------# sub _regex_or_code { my ($value,$valid) = @_; return 1 unless defined $valid; if ( ref($valid) eq 'CODE' ) { local $_ = $value; return $valid->($value); } else { return $value =~ /^$valid$/; } } #--------------------------------------------------------------------------# # _set_defaults() #--------------------------------------------------------------------------# sub _set_defaults { my ($self) = @_; my %default; for my $k ( keys %{$self->{spec}} ) { my $spec = $self->{spec}{$k}; my $d = exists ($spec->{default}) ? $spec->{default} : undef; my $type = $self->{spec}{$k}{type}; my $strip = $self->{strip}{$k}; throw_spec("Default for list '$spec->{canon}' must be array reference") if ( $type eq "list" && defined $d && ref($d) ne "ARRAY" ); throw_spec("Default for keypair '$spec->{canon}' must be hash reference") if ( $type eq "keypair" && defined $d && ref($d) ne "HASH" ); if (defined $d) { throw_spec("Default '$spec->{canon}' = '$d' fails to validate") unless _validate_value($self, $d, $spec->{valid}); } $default{$strip} = do { local $_ = $type; /switch/ ? (defined $d ? $d: 0) : /counter/ ? (defined $d ? $d: 0) : /parameter/ ? $d : /list/ ? (defined $d ? dclone($d): []) : /keypair/ ? (defined $d ? dclone($d): {}) : undef; }; } $self->{default} = \%default; } #--------------------------------------------------------------------------# # _split_equals() #--------------------------------------------------------------------------# sub _split_equals { my ($self,$raw) = @_; my ($arg,$val); if ( $raw =~ /^($NEGATIVE?$VALID_NAME|$SHORT_BUNDLE)=(.*)/ ) { $arg = $1; $val = $2; } else { $arg = $raw; } return ($arg, $val); } #--------------------------------------------------------------------------# # _switch() #--------------------------------------------------------------------------# sub _switch { my ($self, $arg, $val, $neg) = @_; throw_argv("Switch can't take a value: $self->{spec}{$arg}{canon}=$val") if defined $val; if (! $neg ) { throw_argv("Switch used twice: $self->{spec}{$arg}{canon}") if $self->{seen}{$arg} > 1; } push @{$self->{parsed}}, [ $arg, 1, $neg ]; } #--------------------------------------------------------------------------# # _unbundle() #--------------------------------------------------------------------------# sub _unbundle { my ($self,$arg, $val) = @_; if ( $arg =~ /^$SHORT_BUNDLE$/ ) { my @flags = split(//,substr($arg,1)); unshift @{$self->{target}}, ("-" . pop(@flags) . "=" . $val) if defined $val; for ( reverse @flags ) { unshift @{$self->{target}}, "-$_"; } return 1; } return 0; } #--------------------------------------------------------------------------# # _validate_prereqs() #--------------------------------------------------------------------------# sub _validate_prereqs { my ($self) = @_; for my $key ( keys %{$self->{spec}} ) { next unless exists $self->{spec}{$key}{needs}; my $needs = $self->{spec}{$key}{needs}; my @prereq = ref($needs) eq 'ARRAY' ? @$needs : ( $needs ); for (@prereq) { throw_spec("Prerequisite '$_' for '$self->{spec}{$key}{canon}' is not recognized") unless _find_arg($self,$_); $_ = _find_arg($self,$_); } $self->{spec}{$key}{needs} = \@prereq; } } #--------------------------------------------------------------------------# # _validate_spec() #--------------------------------------------------------------------------# sub _validate_spec { my ($self,$names,$details) = @_; for my $name ( @$names ) { my $alt_name = $name; $alt_name =~ s/^-*// unless $self->{strict}; throw_spec( "'$name' is not a valid option name/alias" ) unless $name =~ /^$VALID_NAME$/; throw_spec( "'$name' is not unique" ) if exists $self->{alias_hr}{$alt_name}; my $strip; ($strip = $name) =~ s/^-+//; throw_spec( "'$strip' conflicts with other options" ) if grep { $strip eq $_ } values %{$self->{strip}}; } for my $key ( keys %$details ) { throw_spec( "'$key' is not a valid option specification key" ) unless grep { $key eq $_ } @valid_keys; } my $type = $details->{type}; throw_spec( "'$type' is not a valid option type" ) unless grep { $type eq $_ } @valid_types; } #--------------------------------------------------------------------------# # _validate_value() #--------------------------------------------------------------------------# sub _validate_value { my ($self, $value, $valid) = @_; return 1 unless defined $valid; if ( ref($value) eq 'HASH' ) { my $valid_key = $valid->[0]; my $valid_val = $valid->[1]; while (my ($k,$v) = each %$value) { _regex_or_code($k, $valid_key) or return 0; _regex_or_code($v, $valid_val) or return 0; } return 1; } elsif ( ref($value) eq 'ARRAY' ) { for (@$value) { _regex_or_code($_, $valid) or return 0; } return 1; } else { return _regex_or_code($value, $valid); } } #--------------------------------------------------------------------------# # AUTOLOAD() #--------------------------------------------------------------------------# sub AUTOLOAD { my $self = shift; my $name = $Getopt::Lucid::AUTOLOAD; $name =~ s/.*:://; # strip fully-qualified portion return if $name eq "DESTROY"; my ($action, $maybe_opt) = $name =~ /^(get|set)_(.+)/ ; if ($action) { # look for a match my $opt; SEARCH: for my $known_opt ( values %{ $self->{strip} } ) { if ( $maybe_opt eq $known_opt ) { $opt = $known_opt; last SEARCH; } # try without dashes (my $fuzzy_opt = $known_opt) =~ s/-/_/g; if ( $maybe_opt eq $fuzzy_opt ) { $opt = $known_opt; last SEARCH; } } # throw if no valid option was found throw_usage("Can't $action unknown option '$maybe_opt'") if ! $opt; # handle the accessor if an option was found if ($action eq "set") { $self->{options}{$opt} = ref($self->{options}{$opt}) eq 'ARRAY' ? [@_] : ref($self->{options}{$opt}) eq 'HASH' ? {@_} : shift; } my $ans = $self->{options}{$opt}; return ref($ans) eq 'ARRAY' ? @$ans : ref($ans) eq 'HASH' ? %$ans : $ans; } my $super = "SUPER::$name"; $self->$super(@_); } 1; # modules must be true __END__ =pod =encoding UTF-8 =head1 NAME Getopt::Lucid - Clear, readable syntax for command line processing =head1 VERSION version 1.08 =head1 SYNOPSIS use Getopt::Lucid qw( :all ); # basic option specifications with aliases @specs = ( Switch("version|V"), Counter("verbose|v"), Param("config|C"), List("lib|l|I"), Keypair("define"), Switch("help|h") ); $opt = Getopt::Lucid->getopt( \@specs )->validate; $verbosity = $opt->get_verbose; @libs = $opt->get_lib; %defs = $opt->get_define; %all_options = $opt->options; # advanced option specifications @adv_spec = ( Param("input"), Param("mode")->default("tcp"), # defaults Param("host")->needs("port"), # dependencies Param("port")->valid(qr/\d+/), # regex validation Param("config")->valid(sub { -r }),# custom validation Param("help")->anycase, # case insensitivity ); $opt = Getopt::Lucid->getopt( \@adv_spec ); $opt->validate({ 'requires' => ['input'] }); # example with a config file $opt = Getopt::Lucid->getopt( \@adv_spec ); use Config::Std; if ( -r $opt->get_config ) { read_config( $opt->get_config() => my %config_hash ); $opt->merge_defaults( $config_hash{''} ); } =head1 DESCRIPTION The goal of this module is providing good code readability and clarity of intent for command-line option processing. While readability is a subjective standard, Getopt::Lucid relies on a more verbose, plain-English option specification as compared against the more symbolic approach of Getopt::Long. Key features include: =over =item * Five option types: switches, counters, parameters, lists, and key pairs =item * Three option styles: long, short (including bundled), and bare (without dashes) =item * Specification of defaults, required options and option dependencies =item * Validation of options with regexes or subroutines =item * Negation of options on the command line =item * Support for parsing any array, not just the default C<<< @ARGV >>> =item * Incorporation of external defaults (e.g. from a config file) with user control of precedence =back =head1 USAGE =head2 Option Styles, Naming and "Strictness" Getopt::Lucid support three kinds of option styles: long-style ("--foo"), short-style ("-f") and bareword style ("foo"). Short-style options are automatically unbundled during command line processing if a single dash is followed by more than one letter (e.g. C<<< -xzf >>> becomes C<<< -x -z -f >>> ). Each option is identified in the specification with a string consisting of the option "name" followed by zero or more "aliases", with any alias (and each subsequent alias) separated by a vertical bar character. E.g.: "lib|l|I" means name "lib", alias "l" and alias "I" Names and aliases must begin with an alphanumeric character, but subsequently may also include both underscore and dash. (E.g. both "input-file" and "input_file" are valid.) While names and aliases are interchangeable when provided on the command line, the "name" portion is used with the accessors for each option (see L). Any of the names and aliases in the specification may be given in any of the three styles. By default, Getopt::Lucid works in "magic" mode, in which option names or aliases may be specified with or without leading dashes, and will be parsed from the command line whether or not they have corresponding dashes. Single-character names or aliases may be read with no dash, one dash or two dashes. Multi-character names or aliases must have either no dashes or two dashes. E.g.: =over =item * Both "foo" and "--foo" as names in the specification may be read from the command line as either "--foo" or "foo" =item * The specification name "f" may be read from the command line as "--f", "-f", or just "f" =back In practice, this means that the specification need not use dashes, but if used on the command line, they will be treated appropriately. Alternatively, Getopt::Lucid can operate in "strict" mode by setting the CEstrictE parameter to a true value. In strict mode, option names and aliases may still be specified in any of the three styles, but they will only be parsed from the command line if they are used in exactly the same style. E.g., given the name and alias "--helpE-h", only "--help" and "-h" are valid for use on the command line. =head2 Option Specification Constructors Options specifications are provided to Getopt::Lucid in an array. Entries in the array must be created with one of several special constructor functions that return a specification object. These constructor functions may be imported either individually or as a group using the import tag ":all" (e.g. C<<< use Getopt::Lucid qw(:all); >>>). The form of the constructor is: TYPE( NAME_ARGUMENT ); The constructor function name indicates the type of option. The name argument is a string with the names and aliases separated by vertical bar characters. The five option specification constructors are: =head3 Switch() A trueEfalse value. Defaults to false. The appearance of an option of this type on the command line sets it to true. =head3 Counter() A numerical counter. Defaults to 0. The appearance of an option of this type on the command line increments the counter by one. =head3 Param() A variable taking an argument. Defaults to "" (the empty string). When an option of this type appears on the command line, the value of the option is set in one of two ways -- appended with an equals sign or from the next argument on the command line: --name=value --name value In the case where white space is used to separate the option name and the value, if the value looks like an option, an exception will be thrown: --name --value # throws an exception =head3 List() This is like C<<< Param() >>> but arguments are pushed onto a list. The default list is empty. =head3 Keypair() A variable taking an argument pair, which are added to a hash. Arguments are handled as with C<<< Param() >>>, but the argument itself must have a key and value joined by an equals sign. --name=key=value --name key=value =head2 Option modifiers An option specification can be further modified with the following methods, each of which return the object modified so that modifier chaining is possible. E.g.: @spec = ( Param("input")->default("/dev/random")->needs("output"), Param("output)->default("/dev/null"), ); =head3 valid() Sets the validation parameter(s) for an option. @spec = ( Param("port")->valid(qr/\d+/), # regex validation Param("config")->valid(sub { -r }), # custom validation Keypair("define") ->valid(\&_valid_key, \&valid_value), # keypairs take two ); See the L section, below, for more. =head3 default() Changes the default for the option to the argument(s) of C<<< default() >>>. List and hashes can take either a list or a reference to an array or hash, respectively. @spec = ( Switch("debug")->default(1), Counter("verbose")->default(3), Param("config")->default("/etc/profile"), List("dirs")->default(qw( /var /home )), Keypair("define")->default( arch => "i386" ), ); =head3 needs() Takes as an argument a list of option names or aliases of dependencies. If the option this modifies appears on the command line, each of the options given as an argument must appear on the command line as well or an exception is thrown. @spec = ( Param("input")->needs("output"), Param("output), ); =head3 anycase() Indicates that the associated option namesEaliases may appear on the command line in lowercase, uppercase, or any mixture of the two. No argument is needed. @spec = ( Switch("help|h")->anycase(), # "Help", "HELP", etc. ); =head2 Validation Validation happens in two stages. First, individual parameters may have validation criteria added to them. Second, the parsed options object may be validated by checking that all requirements collectively are met. =head3 Parameter validation The Param, List, and Keypair option types may be provided an optional validation specification. Values provided on the command line will be validated according to the specification or an exception will be thrown. A validation specification can be either a regular expression, or a reference to a subroutine. Keypairs take up to two validation specifiers. The first is applied to keys and the second is applied to values; either can be left undef to ignore validation. (More complex validation of specific values for specific keys must be done manually.) Validation is also applied to default values provided via the C<<< default() >>> modifier or later modified with C<<< append_defaults >>>, C<<< merge_defaults >>>, or C<<< replace_defaults >>>. This ensures internal consistency. If no default is explicitly provided, validation is only applied if the option appears on the command line. (In other words, the built-in defaults are always considered valid if the option does not appear.) If this is not desired, the C<<< required >>> option to the C<<< validate >>> method should be used to force users to provide an explicit value. # Must be provided and is thus always validated @spec = ( Param("width")->valid(qr/\d+/) ); $opt = Getopt::Lucid->getopt(\@spec); $opt->validate( {requires => ['width']} ); For validation subroutines, the value found on the command line is passed as the first element of C<<< @_ >>>, and C<<< $_ >>> is also set equal to the first element. (N.B. Changing C<<< $_ >>> will not change the value that is captured.) The value validates if the subroutine returns a true value. For validation with regular expressions, consider using L for a ready library of validation options. Older versions of Getopt::Lucid used validation arguments provided in the Spec constructor. This is still supported, but is deprecated and discouraged. It may be removed in a future version of Getopt::Lucid. # deprecated Param("height", qr/\d+/) =head3 Options object validation The C<<< validate >>> method should be called on the result of C<<< getopt >>>. This will check that all parameter prerequisites defined by C<<< needs >>> have been met. It also takes a hashref of arguments. The optional C<<< requires >>> argument gives an arrayref of parameters that must exist. The reason that object validation is done separate from C<<< getopt >>> is to allow for better control over different options that might be required or to allow some dependencies (i.e. from C<<< needs >>>) to be met via a configuration file. @spec = ( Param("action")->needs(qw/user password/), Param("user"), Param("password"), ); $opt = Getopt::Lucid->getopt(\@spec); $opt->merge_defaults( read_config() ); # provides 'user' & 'password' $opt->validate({requires => ['action']}); =head2 Parsing the Command Line Technically, Getopt::Lucid scans an array for command line options, not a command-line string. By default, this array is C<<< @ARGV >>> (though other arrays can be used -- see C<<< new() >>>), which is typically provided by the operating system according to system-specific rules. When Getopt::Lucid processes the array, it scans the array in order, removing any specified command line options and any associated arguments, and leaving behind any unrecognized elements in the array. If an element consisting solely of two-dashes ("--") is found, array scanning is terminated at that point. Any options found during scanning are applied in order. E.g.: @ARGV = qw( --lib /tmp --lib /var ); my $opt = Getopt::Lucid->getopt( [ List("lib") ] ); print join ", " $opt->lib; # prints "/tmp, /var" If an element encountered in processing begins with a dash, but is not recognized as a short-form or long-form option name or alias, an exception will be thrown. =head2 Negation Getopt::Lucid also supports negating options. Options are negated if the option is specified with "no-" or "--no-" prefixed to a name or alias. By default, negation clears the option: Switch and Counter options are set to zero; Param options are set to ""; List and Keypair options are set to an empty list and empty hash, respectively. For List and Keypair options, it is also possible to negate a specific list element or hash key by placing an equals sign and the list element or key immediately after the option name: --no-lib=/tmp --no-define=arch # removes "/tmp" from lib and the "arch" key from define As with all options, negation is processed in order, allowing a "reset" in the middle of command line processing. This may be useful for those using command aliases who wish to "switch off" options in the alias. E.g, in Unix: $ alias wibble = wibble.pl --verbose $ wibble --no-verbose # @ARGV would contain ( "--verbose", "--no-verbose" ) This also may have applications in post-processing configuration files (see L). =head2 Accessors and Mutators After processing the command-line array, the values of the options may be read or modified using accessorsEmutators of the form "get_NAME" and "set_NAME", where NAME represents the option name in the specification without any leading dashes. E.g. @spec = ( Switch("--test|-t"), List("--lib|-L"), Keypair("--define|-D"), ); $opt = Getopt::Lucid->getopt( \@spec ); print $opt->get_test ? "True" : "False"; $opt->set_test(1); For option names with dashes, underscores should be substituted in the accessor calls. E.g. @spec = ( Param("--input-file|-i") ); $opt = Getopt::Lucid->getopt( \@spec ); print $opt->get_input_file; This can create an ambiguous case if a similar option exists with underscores in place of dashes. (E.g. "input_file" and "input-file".) Users can safely avoid these problems by choosing to use either dashes or underscores exclusively and not mixing the two styles. List and Keypair options are returned as flattened lists: my @lib = $opt->get_lib; my %define = $opt->get_define; Using the "set_NAME" mutator is not recommended and should be used with caution. No validation is performed and changes will be lost if the results of processing the command line array are recomputed (e.g, such as occurs if new defaults are applied). List and Keypair options mutators take a list, not references. =head2 Managing Defaults and Config Files A typical problem for command-line option processing is the precedence relationship between default option values specified within the program, default option values stored in a configuration file or in environment variables, and option values specified on the command-line, particularly when the command-line specifies an alternate configuration file. Getopt::Lucid takes the following approach to this problem: =over =item * Initial default values may be specified as part of the option specification (using the C<<< default() >>> modifier) =item * Default values from the option specification may be modified or replaced entirely with default values provided in an external hash (such as from a standard config file or environment variables) =item * When the command-line array is processed, options and their arguments are stored in the order they appeared in the command-line array =item * The stored options are applied in-order to modify or replace the set of "current" default option values =item * If default values are subsequently changed (such as from an alternative configuration file), the stored options are re-applied in-order to the new set of default option values =back With this approach, the resulting option set is always the result of applying options (or negations) from the command-line array to a set of default-values. Users have complete freedom to apply whatever precedence rules they wish to the default values and may even change default values after the command-line array is processed without losing the options given on the command line. Getopt::Lucid provides several functions to assist in manipulating default values: =over =item * C<<< merge_defaults() >>> -- new defaults overwrite any matching, existing defaults. KeyPairs hashes and List arrays are replaced entirely with new defaults =item * C<<< append_defaults() >>> -- new defaults overwrite any matching, existing defaults, except for Counter and List options, which have the new defaults added and appended, respectively, and KeyPair options, which are flattened into any existing default hash =item * C<<< replace_defaults() >>> -- new defaults replace existing defaults; any options not provided in the new defaults are reset to zeroEempty, ignoring any default given in the option specification =item * C<<< reset_defaults() >>> -- returns defaults to values given in the options specification =back =head2 Exceptions and Error Handling Getopt::Lucid uses L for exceptions. When a major error occurs, Getopt::Lucid will die and throw one of three Exception::Class subclasses: =over =item * C<<< Getopt::Lucid::Exception::Usage >>> -- thrown when Getopt::Lucid methods are called incorrectly =item * C<<< Getopt::Lucid::Exception::Spec >>> -- thrown when the specification array contains incorrect or invalid data =item * C<<< Getopt::Lucid::Exception::ARGV >>> -- thrown when the command-line is processed and fails to pass specified validation, requirements, or is otherwise determined to be invalid =back These exception may be caught using an C<<< eval >>> block and allow the calling program to respond differently to each class of exception. my $opt; eval { $opt = Getopt::Lucid->getopt( \@spec ) }; if ($@) { print "$@\n" && print_usage() && exit 1 if ref $@ eq 'Getopt::Lucid::Exception::ARGV'; ref $@ ? $@->rethrow : die $@; } =head2 Ambiguous Cases and Gotchas =head3 One-character aliases and C<<< anycase >>> @spec = ( Counter("verbose|v")->anycase, Switch("version|V")->anycase, ); Consider the spec above. By specifying C<<< anycase >>> on these, "verbose", "Verbose", "VERBOSE" are all acceptable, as are "version", "Version" and so on. (Including long-form versions of these, too, if "magic" mode is used.) However, what if the command line has "-v" or even "-v -V"? In this case, the rule is that exact case matches are used before case-insensitive matches are searched. Thus, "-v" can only match "verbose", despite the C<<< anycase >>> modification, and likewise "-V" can only match "version". =head3 Identical names except for dashes and underscores @spec = ( Param("input-file"), Switch("input_file"), ); Consider the spec above. These are two, separate, valid options, but a call to the accessor C<<< get_input_file >>> is ambiguous and may return either option, depending on which first satisfies a "fuzzy-matching" algorithm inside the accessor code. Avoid identical names with mixed dash and underscore styles. =for Pod::Coverage getopts =head1 METHODS =head2 new() $opt = Getopt::Lucid->new( \@option_spec ); $opt = Getopt::Lucid->new( \@option_spec, \%parameters ); $opt = Getopt::Lucid->new( \@option_spec, \@option_array ); $opt = Getopt::Lucid->new( \@option_spec, \@option_array, \%parameters ); Creates a new Getopt::Lucid object. An array reference to an option spec is required as an argument. (See L for a description of the object spec). By default, objects will be set to read @ARGV for command line options. An optional second argument with a reference to an array will use that array for option processing instead. The final argument may be a hashref of parameters. The only valid parameter currently is: =over =item * strict -- enables strict mode when true =back For typical cases, users will likely prefer to call C<<< getopt >>> instead, which creates a new object and parses the command line with a single function call. =head2 validate() $opt->validate(); $opt->validate( \%arguments ); Takes an optional argument hashref, validates that all requirements and prerequisites are met or throws an error. Valid argument keys are: =over =item * C<<< requires >>> -- an arrayref of options that must exist in the options object. =back This method returns the object for convenient chaining: $opt = Getopt::Lucid->getopt(\@spec)->validate; =head2 append_defaults() %options = append_defaults( %config_hash ); %options = append_defaults( \%config_hash ); Takes a hash or hash reference of new default values, modifies the stored defaults, recalculates the result of processing the command line with the revised defaults, and returns a hash with the resulting options. Each keyEvalue pair in the passed hash is added to the stored defaults. For Switch and Param options, the value in the passed hash will overwrite any preexisting value. For Counter options, the value is added to any preexisting value. For List options, the value (or values, if the value is an array reference) will be pushed onto the end of the list of existing values. For Keypair options, the keyEvalue pairs will be added to the existing hash, overwriting existing keyEvalue pairs (just like merging two hashes). Keys which are not valid names from the options specification will be ignored. =head2 defaults() %defaults = $opt->defaults(); Returns a hash containing current default values. Keys are names from the option specification (without any leading dashes). These defaults represent the baseline values that are modified by the parsed command line options. =head2 getopt() $opt = Getopt::Lucid->getopt( \@option_spec ); $opt = Getopt::Lucid->getopt( \@option_spec, \@option_array ); $opt->getopt(); Parses the command line array (@ARGV by default). When called as a class function, C<<< getopt >>> takes the same arguments as C<<< new >>>, calls C<<< new >>> to create an object before parsing the command line, and returns the new object. When called as an object method, it takes no arguments and returns itself. For convenience, CEgetopts()E is a alias for CEgetopt()E. =head2 merge_defaults() %options = merge_defaults( %config_hash ); %options = merge_defaults( \%config_hash ); Takes a hash or hash reference of new default values, modifies the stored defaults, recalculates the result of processing the command line with the revised defaults, and returns a hash with the resulting options. Each keyEvalue pair in the passed hash is added to the stored defaults, overwriting any preexisting value. Keys which are not valid names from the options specification will be ignored. =head2 names() @names = $opt->names(); Returns the list of names in the options specification. Each name represents a key in the hash of options provided by C<<< options >>>. =head2 options() %options = $opt->options(); Returns a deep copy of the options hash. Before C<<< getopt >>> is called, its behavior is undefined. After C<<< getopt >>> is called, this will return the result of modifying the defaults with the results of command line processing. =head2 replace_defaults() %options = replace_defaults( %config_hash ); %options = replace_defaults( \%config_hash ); Takes a hash or hash reference of new default values, replaces the stored defaults, recalculates the result of processing the command line with the revised defaults, and returns a hash with the resulting options. Each keyEvalue pair in the passed hash replaces existing defaults, including those given in the option specifications. Keys which are not valid names from the option specification will be ignored. =head2 reset_defaults() %options = reset_defaults(); Resets the stored defaults to the original values from the options specification, recalculates the result of processing the command line with the restored defaults, and returns a hash with the resulting options. This undoes the effect of a C<<< merge_defaults >>> or C<<< add_defaults >>> call. =head1 API CHANGES In 1.00, the following API changes have been made: =over =item * C<<< new() >>> now takes an optional hashref of parameters as the last argument =item * The global C<<< $STRICT >>> variable has been replaced with a per-object parameter C<<< strict >>> =item * The C<<< required >>> modifier has been removed and a new C<<< validate >>> method has been added to facilitate lateEcustom checks of required options =back =head1 SEE ALSO =over =item * L =item * L =item * L =item * L =item * L =back =head1 BUGS Please report any bugs or feature using the CPAN Request Tracker. Bugs can be submitted through the web interface at L When submitting a bug or request, please include a test-file or a patch to an existing test-file that illustrates the bug or desired feature. =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan =head1 SUPPORT =head2 Bugs / Feature Requests Please report any bugs or feature requests through the issue tracker at L. You will be notified automatically of any progress on your issue. =head2 Source Code This is open source software. The code repository is available for public review and contribution under the terms of the license. L git clone https://github.com/dagolden/getopt-lucid.git =head1 AUTHOR David Golden =head1 CONTRIBUTORS =for stopwords David Golden Precious James E Keenan Kevin McGrath Nova Patch Robert Bohne =over 4 =item * David Golden =item * David Precious =item * James E Keenan =item * Kevin McGrath =item * Nova Patch =item * Robert Bohne =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2017 by David Golden. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut Getopt-Lucid-1.08/lib/Getopt/Lucid/Exception.pm000644 000765 000024 00000002600 13074555746 021556 0ustar00davidstaff000000 000000 use 5.006; use strict; use warnings; package Getopt::Lucid::Exception; # ABSTRACT: Exception classes for Getopt::Lucid our $VERSION = '1.08'; use Exporter; our @ISA = qw/Exporter Exception::Class::Base/; our @EXPORT = qw( throw_spec throw_argv throw_usage); use Exception::Class 1.23 ( "Getopt::Lucid::Exception" => { description => "Unidentified exception", }, "Getopt::Lucid::Exception::Spec" => { description => "Invalid specification", }, "Getopt::Lucid::Exception::ARGV" => { description => "Invalid argument on command line", }, "Getopt::Lucid::Exception::Usage" => { description => "Invalid usage", }, ); my %throwers = ( throw_spec => "Getopt::Lucid::Exception::Spec", throw_argv => "Getopt::Lucid::Exception::ARGV", throw_usage => "Getopt::Lucid::Exception::Usage", ); for my $t ( keys %throwers ) { no strict 'refs'; *{$t} = sub { $throwers{$t}->throw("$_[0]\n") }; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Getopt::Lucid::Exception - Exception classes for Getopt::Lucid =head1 VERSION version 1.08 =for Pod::Coverage description throw_argv throw_spec throw_usage =head1 AUTHOR David Golden =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2017 by David Golden. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut Getopt-Lucid-1.08/examples/cpanget000755 000765 000024 00000001460 13074555746 017402 0ustar00davidstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Getopt::Lucid qw( :all ); use WWW::Mechanize; my $CPAN_DIST_URL = 'http://search.cpan.org/dist/'; my @option_specs = ( Param('--dist|-d')->required, Param('--version|-v'), ); my $opt = Getopt::Lucid->getopt( \@option_specs ); my $dist_name = $opt->get_dist . $opt->get_version; print "Looking for $dist_name...\n"; my $output_file = $dist_name . ".tar.gz"; my $mech = WWW::Mechanize->new( autocheck => 1 ); $mech->get( $CPAN_DIST_URL . $dist_name ); my $download_url = $mech->find_link( text_regex => qr/download/i ); die "Couldn't find $dist_name\n" unless $download_url; my $filename = ( split q{/}, $download_url->url )[-1] || $output_file; print "Downloading $filename\n"; $mech->get( $download_url->url_abs, ':content_file' => $filename);