@@ -0,0 +1,100 @@
+## 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 than many of the
+usual files you might expect are not in the repository, but are generated at
+release time (e.g. Makefile.PL).
+
+Generally, **you do not need Dist::Zilla to contribute patches**. You do need
+Dist::Zilla to create a tarball and/or install from the repository. See below
+for guidance.
+
+### Getting dependencies
+
+See the included `cpanfile` file for a list of dependencies. If you have
+App::cpanminus 1.6 or later installed, you can use `cpanm` to satisfy
+dependencies like this:
+
+ $ cpanm --installdeps .
+
+Otherwise, you can install Module::CPANfile 1.0002 or later and then satisfy
+dependencies with the regular `cpan` client and `cpanfile-dump`:
+
+ $ cpan `cpanfile-dump`
+
+### 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. Depending on the
+distribution, some of my documentation may be written in a Pod dialect called
+WikiDoc. (See Pod::WikiDoc on CPAN.)
+
+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.
+
+### Installing from the repository
+
+If you want to install directly from the repository, you need to have
+Dist::Zilla installed (see below). If this is a burden to you, I welcome
+patches against a CPAN tarball instead of the repository.
+
+### Installing and using Dist::Zilla
+
+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
+
+To install from the repository, use:
+
+ $ dzil install
+
+You can learn more about Dist::Zilla at http://dzil.org/
+
@@ -1,5 +1,29 @@
Revision history for Metabase-Fact
+0.024 2014-02-13 14:30:03-05:00 America/New_York
+
+ [CHANGED]
+
+ - Dropped use of Test::Exceptions in favor of Test::Fatal (Karen
+ Etheridge)
+
+0.023 2013-09-25 13:53:13 America/New_York
+
+ [FIXED]
+
+ - Compile test could hang on Windows
+
+ [PREREQS]
+
+ - Dropped configure_requires for ExtUtils::MakeMaker to 6.17
+
+0.022 2013-09-11 09:30:13 America/New_York
+
+ [FIXED]
+
+ - metabase-profile now prompts with IO::Prompt::Tiny to fix
+ some hanging bug on Win32
+
0.021 2012-02-14 14:47:54 EST5EDT
- Fixed generated NAME Pod section for metabase-profile
@@ -120,3 +144,5 @@ Revision history for Metabase-Fact
0.001 2009-06-24
- "YAPC::NA::2009, Pittsburgh" Release
+
+# vim: ts=2 sts=2 sw=2 et:
@@ -1,4 +1,4 @@
-This software is Copyright (c) 2012 by David Golden.
+This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
@@ -1,3 +1,5 @@
+# This file was automatically generated by Dist::Zilla::Plugin::Manifest v5.013.
+CONTRIBUTING
Changes
LICENSE
MANIFEST
@@ -5,9 +7,9 @@ META.json
META.yml
Makefile.PL
README
-README.PATCHING
README.hacking
bin/metabase-profile
+cpanfile
dist.ini
lib/Metabase/Fact.pm
lib/Metabase/Fact/Hash.pm
@@ -25,7 +27,8 @@ lib/Metabase/User/EmailAddress.pm
lib/Metabase/User/FullName.pm
lib/Metabase/User/Profile.pm
lib/Metabase/User/Secret.pm
-t/00-compile.t
+perlcritic.rc
+t/00-report-prereqs.t
t/base.t
t/fact/hash.t
t/fact/string.t
@@ -39,9 +42,12 @@ t/resource/base.t
t/resource/cpan.t
t/resource/perl.t
t/user/profile.t
+tidyall.ini
+xt/author/00-compile.t
xt/author/critic.t
xt/author/pod-spell.t
xt/release/distmeta.t
+xt/release/minimum-version.t
xt/release/pod-coverage.t
xt/release/pod-syntax.t
xt/release/portability.t
@@ -6,7 +6,7 @@
"H.Merijn Brand <hmbrand@cpan.org>"
],
"dynamic_config" : 0,
- "generated_by" : "Dist::Zilla version 4.300005, CPAN::Meta::Converter version 2.112621",
+ "generated_by" : "Dist::Zilla version 5.013, CPAN::Meta::Converter version 2.133380",
"license" : [
"apache_2_0"
],
@@ -29,113 +29,143 @@
"prereqs" : {
"configure" : {
"requires" : {
- "ExtUtils::MakeMaker" : "6.30"
+ "ExtUtils::MakeMaker" : "6.17"
+ }
+ },
+ "develop" : {
+ "requires" : {
+ "Dist::Zilla" : "5.013",
+ "Dist::Zilla::PluginBundle::DAGOLDEN" : "0.060",
+ "File::Spec" : "0",
+ "File::Temp" : "0",
+ "IO::Handle" : "0",
+ "IPC::Open3" : "0",
+ "Pod::Coverage::TrustPod" : "0",
+ "Test::CPAN::Meta" : "0",
+ "Test::More" : "0",
+ "Test::Pod" : "1.41",
+ "Test::Pod::Coverage" : "1.08"
}
},
"runtime" : {
"requires" : {
- "CPAN::DistnameInfo" : 0,
- "Carp" : 0,
- "Data::GUID" : 0,
- "Getopt::Long" : 0,
+ "CPAN::DistnameInfo" : "0",
+ "Carp" : "0",
+ "Data::GUID" : "0",
+ "Getopt::Long" : "0",
+ "IO::Prompt::Tiny" : "0",
"JSON" : "2",
- "Pod::Usage" : 0,
- "overload" : 0,
+ "Pod::Usage" : "0",
+ "overload" : "0",
"perl" : "5.006",
- "strict" : 0,
- "warnings" : 0
+ "strict" : "0",
+ "warnings" : "0"
}
},
"test" : {
+ "recommends" : {
+ "CPAN::Meta" : "0",
+ "CPAN::Meta::Requirements" : "2.120900"
+ },
"requires" : {
- "Cwd" : 0,
- "File::Find" : 0,
- "File::Spec" : 0,
+ "Cwd" : "0",
+ "ExtUtils::MakeMaker" : "0",
+ "File::Spec" : "0",
+ "File::Spec::Functions" : "0",
"File::Temp" : "0.20",
- "Test::Exception" : 0,
- "Test::More" : "0.88"
+ "List::Util" : "0",
+ "Test::Fatal" : "0",
+ "Test::More" : "0.88",
+ "lib" : "0",
+ "version" : "0"
}
}
},
"provides" : {
"Metabase::Fact" : {
"file" : "lib/Metabase/Fact.pm",
- "version" : "0.021"
+ "version" : "0.024"
},
"Metabase::Fact::Hash" : {
"file" : "lib/Metabase/Fact/Hash.pm",
- "version" : "0.021"
+ "version" : "0.024"
},
"Metabase::Fact::String" : {
"file" : "lib/Metabase/Fact/String.pm",
- "version" : "0.021"
+ "version" : "0.024"
},
"Metabase::Report" : {
"file" : "lib/Metabase/Report.pm",
- "version" : "0.021"
+ "version" : "0.024"
},
"Metabase::Resource" : {
"file" : "lib/Metabase/Resource.pm",
- "version" : "0.021"
+ "version" : "0.024"
},
"Metabase::Resource::cpan" : {
"file" : "lib/Metabase/Resource/cpan.pm",
- "version" : "0.021"
+ "version" : "0.024"
},
"Metabase::Resource::cpan::distfile" : {
"file" : "lib/Metabase/Resource/cpan/distfile.pm",
- "version" : "0.021"
+ "version" : "0.024"
},
"Metabase::Resource::metabase" : {
"file" : "lib/Metabase/Resource/metabase.pm",
- "version" : "0.021"
+ "version" : "0.024"
},
"Metabase::Resource::metabase::fact" : {
"file" : "lib/Metabase/Resource/metabase/fact.pm",
- "version" : "0.021"
+ "version" : "0.024"
},
"Metabase::Resource::metabase::user" : {
"file" : "lib/Metabase/Resource/metabase/user.pm",
- "version" : "0.021"
+ "version" : "0.024"
},
"Metabase::Resource::perl" : {
"file" : "lib/Metabase/Resource/perl.pm",
- "version" : "0.021"
+ "version" : "0.024"
},
"Metabase::Resource::perl::commit" : {
"file" : "lib/Metabase/Resource/perl/commit.pm",
- "version" : "0.021"
+ "version" : "0.024"
},
"Metabase::User::EmailAddress" : {
"file" : "lib/Metabase/User/EmailAddress.pm",
- "version" : "0.021"
+ "version" : "0.024"
},
"Metabase::User::FullName" : {
"file" : "lib/Metabase/User/FullName.pm",
- "version" : "0.021"
+ "version" : "0.024"
},
"Metabase::User::Profile" : {
"file" : "lib/Metabase/User/Profile.pm",
- "version" : "0.021"
+ "version" : "0.024"
},
"Metabase::User::Secret" : {
"file" : "lib/Metabase/User/Secret.pm",
- "version" : "0.021"
+ "version" : "0.024"
}
},
"release_status" : "stable",
"resources" : {
"bugtracker" : {
- "mailto" : "bug-metabase-fact at rt.cpan.org",
- "web" : "http://rt.cpan.org/Public/Dist/Display.html?Name=Metabase-Fact"
+ "web" : "https://github.com/dagolden/Metabase-Fact/issues"
},
- "homepage" : "https://github.com/dagolden/metabase-fact",
+ "homepage" : "https://github.com/dagolden/Metabase-Fact",
"repository" : {
"type" : "git",
- "url" : "https://github.com/dagolden/metabase-fact.git",
- "web" : "https://github.com/dagolden/metabase-fact"
+ "url" : "https://github.com/dagolden/Metabase-Fact.git",
+ "web" : "https://github.com/dagolden/Metabase-Fact"
}
},
- "version" : "0.021"
+ "version" : "0.024",
+ "x_authority" : "cpan:DAGOLDEN",
+ "x_contributors" : [
+ "David Steinbrunner <dsteinbrunner@pobox.com>",
+ "Karen Etheridge <ether@cpan.org>",
+ "Nathan Gary Glenn <nglenn@cpan.org>",
+ "Randy Stauner <rwstauner@cpan.org>"
+ ]
}
@@ -5,20 +5,24 @@ author:
- 'Ricardo Signes <rjbs@cpan.org>'
- 'H.Merijn Brand <hmbrand@cpan.org>'
build_requires:
- Cwd: 0
- File::Find: 0
- File::Spec: 0
- File::Temp: 0.20
- Test::Exception: 0
- Test::More: 0.88
+ Cwd: '0'
+ ExtUtils::MakeMaker: '0'
+ File::Spec: '0'
+ File::Spec::Functions: '0'
+ File::Temp: '0.20'
+ List::Util: '0'
+ Test::Fatal: '0'
+ Test::More: '0.88'
+ lib: '0'
+ version: '0'
configure_requires:
- ExtUtils::MakeMaker: 6.30
+ ExtUtils::MakeMaker: '6.17'
dynamic_config: 0
-generated_by: 'Dist::Zilla version 4.300005, CPAN::Meta::Converter version 2.112621'
+generated_by: 'Dist::Zilla version 5.013, CPAN::Meta::Converter version 2.133380'
license: apache
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
+ version: '1.4'
name: Metabase-Fact
no_index:
directory:
@@ -31,65 +35,72 @@ no_index:
provides:
Metabase::Fact:
file: lib/Metabase/Fact.pm
- version: 0.021
+ version: '0.024'
Metabase::Fact::Hash:
file: lib/Metabase/Fact/Hash.pm
- version: 0.021
+ version: '0.024'
Metabase::Fact::String:
file: lib/Metabase/Fact/String.pm
- version: 0.021
+ version: '0.024'
Metabase::Report:
file: lib/Metabase/Report.pm
- version: 0.021
+ version: '0.024'
Metabase::Resource:
file: lib/Metabase/Resource.pm
- version: 0.021
+ version: '0.024'
Metabase::Resource::cpan:
file: lib/Metabase/Resource/cpan.pm
- version: 0.021
+ version: '0.024'
Metabase::Resource::cpan::distfile:
file: lib/Metabase/Resource/cpan/distfile.pm
- version: 0.021
+ version: '0.024'
Metabase::Resource::metabase:
file: lib/Metabase/Resource/metabase.pm
- version: 0.021
+ version: '0.024'
Metabase::Resource::metabase::fact:
file: lib/Metabase/Resource/metabase/fact.pm
- version: 0.021
+ version: '0.024'
Metabase::Resource::metabase::user:
file: lib/Metabase/Resource/metabase/user.pm
- version: 0.021
+ version: '0.024'
Metabase::Resource::perl:
file: lib/Metabase/Resource/perl.pm
- version: 0.021
+ version: '0.024'
Metabase::Resource::perl::commit:
file: lib/Metabase/Resource/perl/commit.pm
- version: 0.021
+ version: '0.024'
Metabase::User::EmailAddress:
file: lib/Metabase/User/EmailAddress.pm
- version: 0.021
+ version: '0.024'
Metabase::User::FullName:
file: lib/Metabase/User/FullName.pm
- version: 0.021
+ version: '0.024'
Metabase::User::Profile:
file: lib/Metabase/User/Profile.pm
- version: 0.021
+ version: '0.024'
Metabase::User::Secret:
file: lib/Metabase/User/Secret.pm
- version: 0.021
+ version: '0.024'
requires:
- CPAN::DistnameInfo: 0
- Carp: 0
- Data::GUID: 0
- Getopt::Long: 0
- JSON: 2
- Pod::Usage: 0
- overload: 0
- perl: 5.006
- strict: 0
- warnings: 0
+ CPAN::DistnameInfo: '0'
+ Carp: '0'
+ Data::GUID: '0'
+ Getopt::Long: '0'
+ IO::Prompt::Tiny: '0'
+ JSON: '2'
+ Pod::Usage: '0'
+ overload: '0'
+ perl: '5.006'
+ strict: '0'
+ warnings: '0'
resources:
- bugtracker: http://rt.cpan.org/Public/Dist/Display.html?Name=Metabase-Fact
- homepage: https://github.com/dagolden/metabase-fact
- repository: https://github.com/dagolden/metabase-fact.git
-version: 0.021
+ bugtracker: https://github.com/dagolden/Metabase-Fact/issues
+ homepage: https://github.com/dagolden/Metabase-Fact
+ repository: https://github.com/dagolden/Metabase-Fact.git
+version: '0.024'
+x_authority: cpan:DAGOLDEN
+x_contributors:
+ - 'David Steinbrunner <dsteinbrunner@pobox.com>'
+ - 'Karen Etheridge <ether@cpan.org>'
+ - 'Nathan Gary Glenn <nglenn@cpan.org>'
+ - 'Randy Stauner <rwstauner@cpan.org>'
@@ -1,26 +1,20 @@
+# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v5.013.
use strict;
use warnings;
use 5.006;
-use ExtUtils::MakeMaker 6.30;
+use ExtUtils::MakeMaker 6.17;
my %WriteMakefileArgs = (
"ABSTRACT" => "base class for Metabase Facts",
"AUTHOR" => "David Golden <dagolden\@cpan.org>, Ricardo Signes <rjbs\@cpan.org>, H.Merijn Brand <hmbrand\@cpan.org>",
- "BUILD_REQUIRES" => {
- "Cwd" => 0,
- "File::Find" => 0,
- "File::Spec" => 0,
- "File::Temp" => "0.20",
- "Test::Exception" => 0,
- "Test::More" => "0.88"
- },
+ "BUILD_REQUIRES" => {},
"CONFIGURE_REQUIRES" => {
- "ExtUtils::MakeMaker" => "6.30"
+ "ExtUtils::MakeMaker" => "6.17"
},
"DISTNAME" => "Metabase-Fact",
"EXE_FILES" => [
@@ -33,30 +27,60 @@ my %WriteMakefileArgs = (
"Carp" => 0,
"Data::GUID" => 0,
"Getopt::Long" => 0,
+ "IO::Prompt::Tiny" => 0,
"JSON" => 2,
"Pod::Usage" => 0,
"overload" => 0,
"strict" => 0,
"warnings" => 0
},
- "VERSION" => "0.021",
+ "TEST_REQUIRES" => {
+ "Cwd" => 0,
+ "ExtUtils::MakeMaker" => 0,
+ "File::Spec" => 0,
+ "File::Spec::Functions" => 0,
+ "File::Temp" => "0.20",
+ "List::Util" => 0,
+ "Test::Fatal" => 0,
+ "Test::More" => "0.88",
+ "lib" => 0,
+ "version" => 0
+ },
+ "VERSION" => "0.024",
"test" => {
"TESTS" => "t/*.t t/fact/*.t t/report/*.t t/resource/*.t t/user/*.t"
}
);
-unless ( eval { ExtUtils::MakeMaker->VERSION(6.56) } ) {
- my $br = delete $WriteMakefileArgs{BUILD_REQUIRES};
- my $pp = $WriteMakefileArgs{PREREQ_PM};
- for my $mod ( keys %$br ) {
- if ( exists $pp->{$mod} ) {
- $pp->{$mod} = $br->{$mod} if $br->{$mod} > $pp->{$mod};
- }
- else {
- $pp->{$mod} = $br->{$mod};
- }
- }
+my %FallbackPrereqs = (
+ "CPAN::DistnameInfo" => 0,
+ "Carp" => 0,
+ "Cwd" => 0,
+ "Data::GUID" => 0,
+ "ExtUtils::MakeMaker" => 0,
+ "File::Spec" => 0,
+ "File::Spec::Functions" => 0,
+ "File::Temp" => "0.20",
+ "Getopt::Long" => 0,
+ "IO::Prompt::Tiny" => 0,
+ "JSON" => 2,
+ "List::Util" => 0,
+ "Pod::Usage" => 0,
+ "Test::Fatal" => 0,
+ "Test::More" => "0.88",
+ "lib" => 0,
+ "overload" => 0,
+ "strict" => 0,
+ "version" => 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}
@@ -2,7 +2,7 @@ NAME
Metabase::Fact - base class for Metabase Facts
VERSION
- version 0.021
+ version 0.024
SYNOPSIS
# defining the fact class
@@ -400,16 +400,16 @@ BUGS
SUPPORT
Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker at
- <http://rt.cpan.org/Public/Dist/Display.html?Name=Metabase-Fact>. You
- will be notified automatically of any progress on your issue.
+ <https://github.com/dagolden/Metabase-Fact/issues>. 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.
- <https://github.com/dagolden/metabase-fact>
+ <https://github.com/dagolden/Metabase-Fact>
- git clone https://github.com/dagolden/metabase-fact.git
+ git clone https://github.com/dagolden/Metabase-Fact.git
AUTHORS
* David Golden <dagolden@cpan.org>
@@ -418,8 +418,17 @@ AUTHORS
* H.Merijn Brand <hmbrand@cpan.org>
+CONTRIBUTORS
+ * David Steinbrunner <dsteinbrunner@pobox.com>
+
+ * Karen Etheridge <ether@cpan.org>
+
+ * Nathan Gary Glenn <nglenn@cpan.org>
+
+ * Randy Stauner <rwstauner@cpan.org>
+
COPYRIGHT AND LICENSE
- This software is Copyright (c) 2012 by David Golden.
+ This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
@@ -1,42 +0,0 @@
-README.PATCHING
-
-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 than many of the
-usual files you might expect are not in the repository, but are generated
-at release time (e.g. Makefile.PL).
-
-However, you can run tests directly using the 'prove' tool:
-
- $ prove -l
- $ prove -lv t/some_test_file.t
-
-For most distributions, 'prove' is entirely sufficent for you to test any
-patches you have.
-
-Likewise, much of the documentation Pod is generated at release time.
-Depending on the distribution, some documentation may be written in a Pod
-dialect called WikiDoc. (See Pod::WikiDoc on CPAN.) 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.
-
-Dist::Zilla is a very powerful authoring tool, but requires a number of
-author-specific plugins. If you would like to use it for contributing,
-install it from CPAN, then run one of the following commands, depending on
-your CPAN client:
-
- $ 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/
-
@@ -2,85 +2,85 @@
use 5.006;
use strict;
use warnings;
+
package metabase_profile; # dzil needs this
# PODNAME: metabase-profile
# ABSTRACT: create a metabase profile
-our $VERSION = '0.021'; # VERSION
+our $VERSION = '0.024'; # VERSION
use Getopt::Long;
use JSON 2;
use Metabase::User::Profile;
use Metabase::User::Secret;
use Pod::Usage;
+use IO::Prompt::Tiny qw(prompt);
-my (%profile, $help, $output, $full_name, $email_address, $password);
+my ( %profile, $help, $output, $full_name, $email_address, $password );
my $result = GetOptions(
- 'help|h' => \$help,
- 'output|o:s' => \$output,
- 'name:s' => \$full_name,
- 'email:s' => \$email_address,
- 'secret:s' => \$password,
+ 'help|h' => \$help,
+ 'output|o:s' => \$output,
+ 'name:s' => \$full_name,
+ 'email:s' => \$email_address,
+ 'secret:s' => \$password,
);
-pod2usage({-verbose => 2}) if ! $result || $help;
+pod2usage( { -verbose => 2 } ) if !$result || $help;
# setup output file and confirm it doesn't exist
-if ( ! defined $output ) {
- $output = "metabase_id.json";
+if ( !defined $output ) {
+ $output = "metabase_id.json";
}
if ( -f $output ) {
- die "Won't over-write existing '$output' file. Aborting.\n";
+ die "Won't over-write existing '$output' file. Aborting.\n";
}
# get profile information
-$profile{full_name} = $full_name if defined $full_name;
-$profile{email_address} = $email_address if defined $email_address;
-$profile{password} = $password if defined $password;
+$profile{full_name} = $full_name if defined $full_name;
+$profile{email_address} = $email_address if defined $email_address;
+$profile{password} = $password if defined $password;
my @prompts = (
- full_name => 'full name',
- email_address => 'email address',
- password => 'password/secret',
+ full_name => 'full name',
+ email_address => 'email address',
+ password => 'password/secret',
);
-$|++; # autoflush prompts
while (@prompts) {
- my ($key, $phrase) = splice(@prompts,0,2);
- next if $profile{$key};
- print "Enter $phrase\: ";
- chomp( my $answer = <STDIN> );
- $profile{$key} = $answer;
+ my ( $key, $phrase ) = splice( @prompts, 0, 2 );
+ next if $profile{$key};
+ chomp( my $answer = prompt("Enter $phrase\: ") );
+ $profile{$key} = $answer;
}
# create profile and secret objects
$password = delete $profile{password};
-my $profile = Metabase::User::Profile->create( %profile );
-my $secret = Metabase::User::Secret->new(
- resource => $profile->resource,
- content => $password,
+my $profile = Metabase::User::Profile->create(%profile);
+my $secret = Metabase::User::Secret->new(
+ resource => $profile->resource,
+ content => $password,
);
# write output
print "Writing profile to '$output'\n";
open my $fh, ">", $output;
-print {$fh} JSON->new->ascii->pretty->encode([
- $profile->as_struct,
- $secret->as_struct,
-]);
+print {$fh}
+ JSON->new->ascii->pretty->encode( [ $profile->as_struct, $secret->as_struct, ] );
close $fh;
chmod 0600, $output;
-
+__END__
=pod
+=encoding UTF-8
+
=head1 NAME
metabase-profile - create a metabase profile
=head1 VERSION
-version 0.021
+version 0.024
=head1 SYNOPSIS
@@ -104,7 +104,7 @@ Valid options include:
-h, --help print man page
If no output file name is given, the default name 'metabase_id.json' will be
-used. If the the output filename (or default) exists, the program will abort
+used. If the output filename (or default) exists, the program will abort
rather than overwrite the file. The output file will be in JSON and contain
the user profile and the user's shared secret.
@@ -138,15 +138,10 @@ H.Merijn Brand <hmbrand@cpan.org>
=head1 COPYRIGHT AND LICENSE
-This software is Copyright (c) 2012 by David Golden.
+This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
-
-
-__END__
-
-
@@ -0,0 +1,47 @@
+requires "CPAN::DistnameInfo" => "0";
+requires "Carp" => "0";
+requires "Data::GUID" => "0";
+requires "Getopt::Long" => "0";
+requires "IO::Prompt::Tiny" => "0";
+requires "JSON" => "2";
+requires "Pod::Usage" => "0";
+requires "overload" => "0";
+requires "perl" => "5.006";
+requires "strict" => "0";
+requires "warnings" => "0";
+
+on 'test' => sub {
+ requires "Cwd" => "0";
+ requires "ExtUtils::MakeMaker" => "0";
+ requires "File::Spec" => "0";
+ requires "File::Spec::Functions" => "0";
+ requires "File::Temp" => "0.20";
+ requires "List::Util" => "0";
+ requires "Test::Fatal" => "0";
+ requires "Test::More" => "0.88";
+ requires "lib" => "0";
+ requires "version" => "0";
+};
+
+on 'test' => sub {
+ recommends "CPAN::Meta" => "0";
+ recommends "CPAN::Meta::Requirements" => "2.120900";
+};
+
+on 'configure' => sub {
+ requires "ExtUtils::MakeMaker" => "6.17";
+};
+
+on 'develop' => sub {
+ requires "Dist::Zilla" => "5.013";
+ requires "Dist::Zilla::PluginBundle::DAGOLDEN" => "0.060";
+ requires "File::Spec" => "0";
+ requires "File::Temp" => "0";
+ requires "IO::Handle" => "0";
+ requires "IPC::Open3" => "0";
+ requires "Pod::Coverage::TrustPod" => "0";
+ requires "Test::CPAN::Meta" => "0";
+ requires "Test::More" => "0";
+ requires "Test::Pod" => "1.41";
+ requires "Test::Pod::Coverage" => "1.08";
+};
@@ -6,15 +6,4 @@ license = Apache_2_0
copyright_holder = David Golden
[@DAGOLDEN]
-:version = 0.026
-stopwords = GUID
-stopwords = IDentifier
-stopwords = JSON
-stopwords = URI's
-stopwords = UTC
-stopwords = analyses
-stopwords = cpan
-stopwords = datatype
-stopwords = distfile
-stopwords = guid
-stopwords = metabase
+:version = 0.060
@@ -1,8 +1,9 @@
use 5.006;
use strict;
use warnings;
+
package Metabase::Fact::Hash;
-our $VERSION = '0.021'; # VERSION
+our $VERSION = '0.024'; # VERSION
use Carp ();
use JSON 2 ();
@@ -11,48 +12,50 @@ use Metabase::Fact;
our @ISA = qw/Metabase::Fact/;
sub validate_content {
- my ($self) = @_;
- my $content = $self->content;
- my $class = ref $self;
- Carp::confess "content must be a hashref"
- unless ref $content eq 'HASH';
- my $get_req =$self->can('required_keys') || sub { () };
- my $get_opt =$self->can('optional_keys') || sub { () };
- # find missing
- my @missing = grep { ! exists $content->{$_} } $get_req->();
- Carp::croak "missing required keys for $class\: @missing\n" if @missing;
- # check for invalid
- my %valid = map { $_ => 1 } ($get_req->(), $get_opt->());
- my @invalid = grep { ! exists $valid{$_} } keys %$content;
- Carp::croak "invalid keys for $class\: @invalid\n" if @invalid;
- return 1;
+ my ($self) = @_;
+ my $content = $self->content;
+ my $class = ref $self;
+ Carp::confess "content must be a hashref"
+ unless ref $content eq 'HASH';
+ my $get_req = $self->can('required_keys') || sub { () };
+ my $get_opt = $self->can('optional_keys') || sub { () };
+ # find missing
+ my @missing = grep { !exists $content->{$_} } $get_req->();
+ Carp::croak "missing required keys for $class\: @missing\n" if @missing;
+ # check for invalid
+ my %valid = map { $_ => 1 } ( $get_req->(), $get_opt->() );
+ my @invalid = grep { !exists $valid{$_} } keys %$content;
+ Carp::croak "invalid keys for $class\: @invalid\n" if @invalid;
+ return 1;
}
sub content_as_bytes {
- my ($self) = @_;
- return JSON->new->ascii->encode($self->content);
+ my ($self) = @_;
+ return JSON->new->ascii->encode( $self->content );
}
sub content_from_bytes {
- my ($class, $bytes) = @_;
- return JSON->new->ascii->decode($bytes);
+ my ( $class, $bytes ) = @_;
+ return JSON->new->ascii->decode($bytes);
}
1;
# ABSTRACT: fact subtype for simple hashes
-
+__END__
=pod
+=encoding UTF-8
+
=head1 NAME
Metabase::Fact::Hash - fact subtype for simple hashes
=head1 VERSION
-version 0.021
+version 0.024
=head1 SYNOPSIS
@@ -160,14 +163,10 @@ H.Merijn Brand <hmbrand@cpan.org>
=head1 COPYRIGHT AND LICENSE
-This software is Copyright (c) 2012 by David Golden.
+This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
-
-
-__END__
-
@@ -1,50 +1,53 @@
use 5.006;
use strict;
use warnings;
+
package Metabase::Fact::String;
-our $VERSION = '0.021'; # VERSION
+our $VERSION = '0.024'; # VERSION
use Carp ();
use Metabase::Fact;
our @ISA = qw/Metabase::Fact/;
-# document that content must be characters, not bytes -- dagolden, 2009-03-28
+# document that content must be characters, not bytes -- dagolden, 2009-03-28
sub validate_content {
- my ($self) = @_;
- Carp::confess "content must be scalar value"
- unless defined $self->content && ref \($self->content) eq 'SCALAR';
+ my ($self) = @_;
+ Carp::confess "content must be scalar value"
+ unless defined $self->content && ref \( $self->content ) eq 'SCALAR';
}
sub content_as_bytes {
- my ($self) = @_;
- my $bytes = $self->content;
- utf8::encode($bytes) if $] ge '5.008'; # converts in-place
- return $bytes;
+ my ($self) = @_;
+ my $bytes = $self->content;
+ utf8::encode($bytes) if $] ge '5.008'; # converts in-place
+ return $bytes;
}
-sub content_from_bytes {
- my ($class, $bytes) = @_;
- utf8::decode($bytes) if $] ge '5.008'; # converts in-place
- return $bytes;
+sub content_from_bytes {
+ my ( $class, $bytes ) = @_;
+ utf8::decode($bytes) if $] ge '5.008'; # converts in-place
+ return $bytes;
}
1;
# ABSTRACT: fact subtype for simple strings
-
+__END__
=pod
+=encoding UTF-8
+
=head1 NAME
Metabase::Fact::String - fact subtype for simple strings
=head1 VERSION
-version 0.021
+version 0.024
=head1 SYNOPSIS
@@ -117,14 +120,10 @@ H.Merijn Brand <hmbrand@cpan.org>
=head1 COPYRIGHT AND LICENSE
-This software is Copyright (c) 2012 by David Golden.
+This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
-
-
-__END__
-
@@ -1,8 +1,9 @@
use 5.006;
use strict;
use warnings;
+
package Metabase::Fact;
-our $VERSION = '0.021'; # VERSION
+our $VERSION = '0.024'; # VERSION
use Carp ();
use Data::GUID guid_string => { -as => '_guid' };
@@ -18,78 +19,80 @@ use Metabase::Resource;
# needed to be a very small set of libraries. Sadly, we've rolled our
# own... -- rjbs, 2009-03-30
sub __validate_args {
- my ($self, $args, $spec) = @_;
- my $hash = (@$args == 1 and ref $args->[0]) ? { %{ $args->[0] } }
- : (@$args == 0) ? { }
- : { @$args };
+ my ( $self, $args, $spec ) = @_;
+ my $hash =
+ ( @$args == 1 and ref $args->[0] ) ? { %{ $args->[0] } }
+ : ( @$args == 0 ) ? {}
+ : {@$args};
- my @errors;
+ my @errors;
- for my $key (keys %$hash) {
- push @errors, qq{unknown argument "$key" when constructing $self}
- unless exists $spec->{ $key };
- }
+ for my $key ( keys %$hash ) {
+ push @errors, qq{unknown argument "$key" when constructing $self}
+ unless exists $spec->{$key};
+ }
- for my $key (grep { $spec->{ $_ } } keys %$spec) {
- push @errors, qq{missing required argument "$key" when constructing $self}
- unless defined $hash->{ $key };
- }
+ for my $key ( grep { $spec->{$_} } keys %$spec ) {
+ push @errors, qq{missing required argument "$key" when constructing $self}
+ unless defined $hash->{$key};
+ }
- Carp::confess(join qq{\n}, @errors) if @errors;
+ Carp::confess( join qq{\n}, @errors ) if @errors;
- return $hash;
+ return $hash;
}
-my $hex = '[0-9a-f]';
+my $hex = '[0-9a-f]';
my $guid_re = qr(\A$hex{8}-$hex{4}-$hex{4}-$hex{4}-$hex{12}\z)i;
sub __validate_guid {
- my ($class, $string) = @_;
- if ( $string !~ $guid_re ) {
- Carp::confess("'$string' is not formatted as a GUID string");
- }
- return lc $string
+ my ( $class, $string ) = @_;
+ if ( $string !~ $guid_re ) {
+ Carp::confess("'$string' is not formatted as a GUID string");
+ }
+ return lc $string;
}
sub validate_resource {
- my ($self, $uri) = @_;
- # Metabase::Resource->new dies if invalid
- my $obj = Metabase::Resource->new($uri);
- if ( ! (ref($obj) && $obj->isa("Metabase::Resource") ) ) {
- Carp::confess("Could not validate '$uri' as a Metabase::Resource");
- }
- return $obj;
+ my ( $self, $uri ) = @_;
+ # Metabase::Resource->new dies if invalid
+ my $obj = Metabase::Resource->new($uri);
+ if ( !( ref($obj) && $obj->isa("Metabase::Resource") ) ) {
+ Carp::confess("Could not validate '$uri' as a Metabase::Resource");
+ }
+ return $obj;
}
sub new {
- my ($class, @args) = @_;
- my $args = $class->__validate_args(
- \@args,
- {
- content => 1,
- resource => 1, # where to validate? -- dagolden, 2009-03-31
- # still optional so we can manipulate anon facts -- dagolden, 2009-05-12
- creator => 0,
- # helpful for constructing facts with non-random guids
- guid => 0,
- },
- );
+ my ( $class, @args ) = @_;
+ my $args = $class->__validate_args(
+ \@args,
+ {
+ content => 1,
+ resource => 1, # where to validate? -- dagolden, 2009-03-31
+ # still optional so we can manipulate anon facts -- dagolden, 2009-05-12
+ creator => 0,
+ # helpful for constructing facts with non-random guids
+ guid => 0,
+ },
+ );
- # create the object
- my $self = $class->_init_guts($args);
+ # create the object
+ my $self = $class->_init_guts($args);
- # validate content
- eval { $self->validate_content };
- if ($@) {
- Carp::confess("$class object content invalid: $@");
- }
+ # validate content
+ eval { $self->validate_content };
+ if ($@) {
+ Carp::confess("$class object content invalid: $@");
+ }
- return $self;
+ return $self;
}
sub _zulu_datetime {
- my ($y,$mo,$d,$h,$mi,$s) = (gmtime)[reverse 0 .. 5];
- return sprintf("%4d-%02d-%02dT%02d:%02d:%02dZ",1900+$y,1+$mo,$d,$h,$mi,$s);
+ my ( $y, $mo, $d, $h, $mi, $s ) = (gmtime)[ reverse 0 .. 5 ];
+ return
+ sprintf( "%4d-%02d-%02dT%02d:%02d:%02dZ", 1900 + $y, 1 + $mo, $d, $h, $mi, $s );
}
sub _bool { return $_[0] ? 1 : 0 }
@@ -98,243 +101,241 @@ sub _bool { return $_[0] ? 1 : 0 }
# only content, resource, guid and creator could exist; in
# the latter case, all fields would exist
sub _init_guts {
- my ($class, $args) = @_;
+ my ( $class, $args ) = @_;
- # confirm type
- $args->{type} = $class->type
- unless defined $args->{type};
+ # confirm type
+ $args->{type} = $class->type
+ unless defined $args->{type};
- Carp::confess("illegal type ($args->{type}) for $class")
- if $args->{type} ne $class->type;
+ Carp::confess("illegal type ($args->{type}) for $class")
+ if $args->{type} ne $class->type;
- # if restoring from_struct, we must cope with older schemas
- $args->{schema_version} = $class->default_schema_version
- unless defined $args->{schema_version};
+ # if restoring from_struct, we must cope with older schemas
+ $args->{schema_version} = $class->default_schema_version
+ unless defined $args->{schema_version};
- $class->upgrade_fact($args)
- if $args->{schema_version} != $class->default_schema_version;
+ $class->upgrade_fact($args)
+ if $args->{schema_version} != $class->default_schema_version;
- # initialize guid if not provided
- if ( ! defined $args->{guid} ) {
- $args->{guid} = lc _guid();
- }
+ # initialize guid if not provided
+ if ( !defined $args->{guid} ) {
+ $args->{guid} = lc _guid();
+ }
- # initialize the object
- my $self = bless {}, $class;
+ # initialize the object
+ my $self = bless {}, $class;
- $self->{content} = $args->{content};
+ $self->{content} = $args->{content};
- my $meta = $self->{metadata} = { core => {} };
- $meta->{core}{guid} = $class->__validate_guid($args->{guid});
- $meta->{core}{creation_time} = $args->{creation_time} || _zulu_datetime();
- $meta->{core}{update_time} = $meta->{core}{creation_time};
- $meta->{core}{schema_version} = $args->{schema_version};
- $meta->{core}{type} = $self->type;
- $meta->{core}{valid} = _bool( defined $args->{valid} ? $args->{valid} : 1 );
+ my $meta = $self->{metadata} = { core => {} };
+ $meta->{core}{guid} = $class->__validate_guid( $args->{guid} );
+ $meta->{core}{creation_time} = $args->{creation_time} || _zulu_datetime();
+ $meta->{core}{update_time} = $meta->{core}{creation_time};
+ $meta->{core}{schema_version} = $args->{schema_version};
+ $meta->{core}{type} = $self->type;
+ $meta->{core}{valid} = _bool( defined $args->{valid} ? $args->{valid} : 1 );
- # validate creator via mutator if given
- $self->set_creator($args->{creator}) if defined $args->{creator};
+ # validate creator via mutator if given
+ $self->set_creator( $args->{creator} ) if defined $args->{creator};
- # validate resource field
- $meta->{core}{resource} = $self->validate_resource($args->{resource});
+ # validate resource field
+ $meta->{core}{resource} = $self->validate_resource( $args->{resource} );
- return $self;
+ return $self;
}
# Content accessor
-sub content { $_[0]->{content} }
+sub content { $_[0]->{content} }
# Accessors for core metadata
-sub creation_time { $_[0]->{metadata}{core}{creation_time} }
-sub guid { $_[0]->{metadata}{core}{guid} }
-sub resource { $_[0]->{metadata}{core}{resource} }
-sub schema_version { $_[0]->{metadata}{core}{schema_version} }
+sub creation_time { $_[0]->{metadata}{core}{creation_time} }
+sub guid { $_[0]->{metadata}{core}{guid} }
+sub resource { $_[0]->{metadata}{core}{resource} }
+sub schema_version { $_[0]->{metadata}{core}{schema_version} }
# Creator can be set once after the fact is created
-sub creator { $_[0]->{metadata}{core}{creator} }
+sub creator { $_[0]->{metadata}{core}{creator} }
sub set_creator {
- my ($self, $uri) = @_;
+ my ( $self, $uri ) = @_;
- Carp::confess("can't set creator; it is already set")
- if $self->creator;
+ Carp::confess("can't set creator; it is already set")
+ if $self->creator;
- # validate $uri
- my $obj = Metabase::Resource->new($uri);
- unless ( $obj->type eq 'Metabase-Resource-metabase-user' ) {
- Carp::confess(
- "creator must be a Metabase User Profile resource URI of\n" .
- "the form 'metabase:user:XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX'"
- );
- }
+ # validate $uri
+ my $obj = Metabase::Resource->new($uri);
+ unless ( $obj->type eq 'Metabase-Resource-metabase-user' ) {
+ Carp::confess( "creator must be a Metabase User Profile resource URI of\n"
+ . "the form 'metabase:user:XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX'" );
+ }
- $self->{metadata}{core}{creator} = $obj;
+ $self->{metadata}{core}{creator} = $obj;
}
# update_time can always be modified
-sub update_time { $_[0]->{metadata}{core}{update_time} }
+sub update_time { $_[0]->{metadata}{core}{update_time} }
sub touch {
- my ($self) = @_;
- $self->{metadata}{core}{update_time} = _zulu_datetime();
+ my ($self) = @_;
+ $self->{metadata}{core}{update_time} = _zulu_datetime();
}
# valid can be modified
-sub valid { $_[0]->{metadata}{core}{valid} }
+sub valid { $_[0]->{metadata}{core}{valid} }
sub set_valid {
- my ($self, $val) = @_;
- $self->{metadata}{core}{valid} = _bool($val)
+ my ( $self, $val ) = @_;
+ $self->{metadata}{core}{valid} = _bool($val);
}
# metadata structure accessors
sub core_metadata {
- my $self = shift;
- return { %{$self->{metadata}{core}} };
+ my $self = shift;
+ return { %{ $self->{metadata}{core} } };
}
sub core_metadata_types {
- return {
- creation_time => '//str',
- creator => '//str',
- guid => '//str',
- resource => '//str',
- schema_version => '//num',
- type => '//str',
- update_time => '//str',
- valid => '//bool',
- }
+ return {
+ creation_time => '//str',
+ creator => '//str',
+ guid => '//str',
+ resource => '//str',
+ schema_version => '//num',
+ type => '//str',
+ update_time => '//str',
+ valid => '//bool',
+ };
}
sub resource_metadata {
- my $self = shift;
- $self->{metadata}{resource} ||= $self->resource->metadata;
- return { %{$self->{metadata}{resource}} };
+ my $self = shift;
+ $self->{metadata}{resource} ||= $self->resource->metadata;
+ return { %{ $self->{metadata}{resource} } };
}
sub resource_metadata_types {
- my $self = shift;
- return $self->resource->metadata_types;
+ my $self = shift;
+ return $self->resource->metadata_types;
}
# persistence routines
# Class might not be in its own file -- check if method can resolve
# or else try to load it
-my $id_re = qr/[_a-z]+/i;
+my $id_re = qr/[_a-z]+/i;
my $class_re = qr/^$id_re(?:::$id_re)*$/;
sub _load_fact_class {
- my ($class, $fact_class) = @_;
- unless ( defined $fact_class ) {
- Carp::confess "Can't load undef as a module";
- }
- unless ( $fact_class =~ $class_re ) {
- Carp::confess "'$fact_class' does not look like a class name";
- }
- unless ( $fact_class->can('type') ) {
- eval "require $fact_class; 1" ## no critic
- or Carp::confess "Could not load fact class $fact_class\: $@";
- }
- return 1;
+ my ( $class, $fact_class ) = @_;
+ unless ( defined $fact_class ) {
+ Carp::confess "Can't load undef as a module";
+ }
+ unless ( $fact_class =~ $class_re ) {
+ Carp::confess "'$fact_class' does not look like a class name";
+ }
+ unless ( $fact_class->can('type') ) {
+ eval "require $fact_class; 1" ## no critic
+ or Carp::confess "Could not load fact class $fact_class\: $@";
+ }
+ return 1;
}
sub as_struct {
- my ($self) = @_;
-
- # turn Metabase::Resources back into URI strings
- my $core = { %{ $self->core_metadata } };
- $core->{resource} = $core->{resource}->resource;
- $core->{creator} = $core->{creator}->resource if exists $core->{creator};
-
- return {
- content => $self->content_as_bytes,
- metadata => {
- # We only provide core metadata here, not resource or content metadata,
- # because we use as_struct for serialized transmission. The remote that
- # receives the transmission should reconstruct the metadata for itself,
- # as it is more likely to have an improved metadata producer. -- rjbs,
- # 2009-06-24
- core => $core,
- }
- };
+ my ($self) = @_;
+
+ # turn Metabase::Resources back into URI strings
+ my $core = { %{ $self->core_metadata } };
+ $core->{resource} = $core->{resource}->resource;
+ $core->{creator} = $core->{creator}->resource if exists $core->{creator};
+
+ return {
+ content => $self->content_as_bytes,
+ metadata => {
+ # We only provide core metadata here, not resource or content metadata,
+ # because we use as_struct for serialized transmission. The remote that
+ # receives the transmission should reconstruct the metadata for itself,
+ # as it is more likely to have an improved metadata producer. -- rjbs,
+ # 2009-06-24
+ core => $core,
+ }
+ };
}
sub from_struct {
- my ($class, $struct) = @_;
-
- # Might be called as Metabase::Fact->from_struct($struct), so we
- # need to find and load the actual fact class
- my $fact_class = $class->class_from_type($struct->{metadata}{core}{type});
- $class->_load_fact_class( $fact_class );
-
- my $metadata = $struct->{metadata};
- my $core_meta = $metadata->{core};
-
- # transfrom struct into content and core metadata arguments the way they
- # would be given to new, then validate these and get an object from
- # _init_guts
- my @args = (
- (map { $_ => $core_meta->{$_} } keys %$core_meta),
- content => $fact_class->content_from_bytes($struct->{content}),
- );
+ my ( $class, $struct ) = @_;
+
+ # Might be called as Metabase::Fact->from_struct($struct), so we
+ # need to find and load the actual fact class
+ my $fact_class = $class->class_from_type( $struct->{metadata}{core}{type} );
+ $class->_load_fact_class($fact_class);
+
+ my $metadata = $struct->{metadata};
+ my $core_meta = $metadata->{core};
+
+ # transform struct into content and core metadata arguments the way they
+ # would be given to new, then validate these and get an object from
+ # _init_guts
+ my @args = (
+ ( map { $_ => $core_meta->{$_} } keys %$core_meta ),
+ content => $fact_class->content_from_bytes( $struct->{content} ),
+ );
- my $args = $fact_class->__validate_args(
- \@args,
- {
- # when thawing, all of these must be provided
- content => 1,
- creation_time => 1,
- guid => 1,
- resource => 1,
- schema_version => 1,
- type => 1,
- valid => 1,
- # still optional so we can manipulate anon facts -- dagolden, 2009-05-12
- creator => 0,
- update_time => 0,
- },
- );
+ my $args = $fact_class->__validate_args(
+ \@args,
+ {
+ # when thawing, all of these must be provided
+ content => 1,
+ creation_time => 1,
+ guid => 1,
+ resource => 1,
+ schema_version => 1,
+ type => 1,
+ valid => 1,
+ # still optional so we can manipulate anon facts -- dagolden, 2009-05-12
+ creator => 0,
+ update_time => 0,
+ },
+ );
- my $self = $fact_class->_init_guts($args);
+ my $self = $fact_class->_init_guts($args);
- return $self;
+ return $self;
}
sub as_json {
- my ($self) = @_;
- return JSON->new->ascii->encode( $self->as_struct );
+ my ($self) = @_;
+ return JSON->new->ascii->encode( $self->as_struct );
}
sub from_json {
- my ($class, $string) = @_;
- my $struct = eval { JSON->new->ascii->decode( $string ) }
- or Carp::confess "Error decoding JSON:\n$@";
- return $class->from_struct( $struct );
+ my ( $class, $string ) = @_;
+ my $struct = eval { JSON->new->ascii->decode($string) }
+ or Carp::confess "Error decoding JSON:\n$@";
+ return $class->from_struct($struct);
}
sub save {
- my ($self, $filename ) = @_;
- my $class = ref($self);
- open my $fh, ">", $filename
- or Carp::confess "Error saving $class to '$filename'\: $!";
- print {$fh} scalar $self->as_json;
- close $fh;
- return 1;
+ my ( $self, $filename ) = @_;
+ my $class = ref($self);
+ open my $fh, ">", $filename
+ or Carp::confess "Error saving $class to '$filename'\: $!";
+ print {$fh} scalar $self->as_json;
+ close $fh;
+ return 1;
}
sub load {
- my ($class, $filename) = @_;
- open my $fh, "<", $filename
- or Carp::confess "Error loading fact from '$filename'\: $!";
- my $string = do { local $/; <$fh> };
- close $fh;
- return $class->from_json($string);
+ my ( $class, $filename ) = @_;
+ open my $fh, "<", $filename
+ or Carp::confess "Error loading fact from '$filename'\: $!";
+ my $string = do { local $/; <$fh> };
+ close $fh;
+ return $class->from_json($string);
}
#--------------------------------------------------------------------------#
@@ -343,20 +344,20 @@ sub load {
# type_from_class
sub type {
- my $self = shift;
- my $type = ref $self || $self;
+ my $self = shift;
+ my $type = ref $self || $self;
- $type =~ s{::}{-}g;
- return $type;
+ $type =~ s{::}{-}g;
+ return $type;
}
# XXX: I'm not really excited about having this in here. -- rjbs, 2009-03-28
# XXX: Need it ->type for symmetry. Make it private? -- dagolden, 2009-03-31
sub class_from_type {
- my (undef, $type) = @_;
- Carp::confess "can't get class from undef type" unless defined $type;
- $type =~ s/-/::/g;
- return $type;
+ my ( undef, $type ) = @_;
+ Carp::confess "can't get class from undef type" unless defined $type;
+ $type =~ s/-/::/g;
+ return $type;
}
#--------------------------------------------------------------------------#
@@ -375,48 +376,48 @@ sub default_schema_version { 1 }
# abstract methods -- mostly fatal
#--------------------------------------------------------------------------#
-sub content_metadata { return +{} }
+sub content_metadata { return +{} }
-sub content_metadata_types { return +{} }
+sub content_metadata_types { return +{} }
sub upgrade_fact {
- my ($self) = @_;
- Carp::confess "Detected a schema mismatch, but upgrade_fact not implemented by "
- . (ref $self || $self)
+ my ($self) = @_;
+ Carp::confess "Detected a schema mismatch, but upgrade_fact not implemented by "
+ . ( ref $self || $self );
}
sub content_as_bytes {
- my ($self, $content) = @_;
- Carp::confess "content_as_bytes not implemented by " . (ref $self || $self)
+ my ( $self, $content ) = @_;
+ Carp::confess "content_as_bytes not implemented by " . ( ref $self || $self );
}
sub content_from_bytes {
- my ($self, $bytes) = @_;
- Carp::confess "content_from_bytes not implemented by "
- . (ref $self || $self)
+ my ( $self, $bytes ) = @_;
+ Carp::confess "content_from_bytes not implemented by " . ( ref $self || $self );
}
sub validate_content {
- my ($self, $content) = @_;
- Carp::confess "validate_content not implemented by " . (ref $self || $self)
+ my ( $self, $content ) = @_;
+ Carp::confess "validate_content not implemented by " . ( ref $self || $self );
}
1;
# ABSTRACT: base class for Metabase Facts
-
-
__END__
+
=pod
+=encoding UTF-8
+
=head1 NAME
Metabase::Fact - base class for Metabase Facts
=head1 VERSION
-version 0.021
+version 0.024
=head1 SYNOPSIS
@@ -848,14 +849,14 @@ L<http://rt.cpan.org/Dist/Display.html?Queue=Metabase-Fact>
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
+=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<http://rt.cpan.org/Public/Dist/Display.html?Name=Metabase-Fact>.
+at L<https://github.com/dagolden/Metabase-Fact/issues>.
You will be notified automatically of any progress on your issue.
=head2 Source Code
@@ -863,9 +864,9 @@ You will be notified automatically of any progress on your issue.
This is open source software. The code repository is available for
public review and contribution under the terms of the license.
-L<https://github.com/dagolden/metabase-fact>
+L<https://github.com/dagolden/Metabase-Fact>
- git clone https://github.com/dagolden/metabase-fact.git
+ git clone https://github.com/dagolden/Metabase-Fact.git
=head1 AUTHORS
@@ -885,13 +886,34 @@ H.Merijn Brand <hmbrand@cpan.org>
=back
+=head1 CONTRIBUTORS
+
+=over 4
+
+=item *
+
+David Steinbrunner <dsteinbrunner@pobox.com>
+
+=item *
+
+Karen Etheridge <ether@cpan.org>
+
+=item *
+
+Nathan Gary Glenn <nglenn@cpan.org>
+
+=item *
+
+Randy Stauner <rwstauner@cpan.org>
+
+=back
+
=head1 COPYRIGHT AND LICENSE
-This software is Copyright (c) 2012 by David Golden.
+This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
-
@@ -1,8 +1,9 @@
use 5.006;
use strict;
use warnings;
+
package Metabase::Report;
-our $VERSION = '0.021'; # VERSION
+our $VERSION = '0.024'; # VERSION
use Carp ();
use JSON 2 ();
@@ -15,19 +16,19 @@ our @ISA = qw/Metabase::Fact/;
#--------------------------------------------------------------------------#
sub report_spec {
- my $self = shift;
- Carp::confess "report_spec method not implemented by " . ref $self;
+ my $self = shift;
+ Carp::confess "report_spec method not implemented by " . ref $self;
}
sub set_creator {
- my ($self, $uri) = @_;
+ my ( $self, $uri ) = @_;
- $self->SUPER::set_creator($uri);
+ $self->SUPER::set_creator($uri);
- for my $fact ($self->facts) {
- $fact->set_creator($uri)
- unless $fact->creator;
- }
+ for my $fact ( $self->facts ) {
+ $fact->set_creator($uri)
+ unless $fact->creator;
+ }
}
#--------------------------------------------------------------------------#
@@ -39,73 +40,74 @@ sub set_creator {
# stage? Maybe we shouldn't let any fields be optional
# XXX should probably refactor arg_spec for Fact->new so we can reuse it
-# and just make the content one optional. -- dagolden, 2009-03-31
+# and just make the content one optional. -- dagolden, 2009-03-31
sub open {
- my ($class, @args) = @_;
-
- my $args = $class->__validate_args(
- \@args,
- {
- resource => 1,
- # still optional so we can manipulate anon facts -- dagolden, 2009-05-12
- creator => 0,
- # helpful for constructing facts with non-random guids
- guid => 0,
- }
- );
+ my ( $class, @args ) = @_;
+
+ my $args = $class->__validate_args(
+ \@args,
+ {
+ resource => 1,
+ # still optional so we can manipulate anon facts -- dagolden, 2009-05-12
+ creator => 0,
+ # helpful for constructing facts with non-random guids
+ guid => 0,
+ }
+ );
- $args->{content} ||= [];
+ $args->{content} ||= [];
- # create and check
- my $self = $class->_init_guts($args);
+ # create and check
+ my $self = $class->_init_guts($args);
- return $self;
+ return $self;
}
sub add {
- my ($self, @args) = @_;
- Carp::confess("report is already closed") if $self->{__closed};
-
- my ($fact, $fact_class, $content );
-
- if ( @args == 1 && $args[0]->isa('Metabase::Fact') ) {
- $fact = $args[0];
- } else {
- ($fact_class, $content) = @args;
- $fact = $fact_class->new(
- resource => $self->resource->resource,
- content => $content,
- );
- }
+ my ( $self, @args ) = @_;
+ Carp::confess("report is already closed") if $self->{__closed};
+
+ my ( $fact, $fact_class, $content );
- $fact->set_creator($self->creator->resource) if $self->creator;
+ if ( @args == 1 && $args[0]->isa('Metabase::Fact') ) {
+ $fact = $args[0];
+ }
+ else {
+ ( $fact_class, $content ) = @args;
+ $fact = $fact_class->new(
+ resource => $self->resource->resource,
+ content => $content,
+ );
+ }
- push @{$self->{content}}, $fact;
- return $self;
+ $fact->set_creator( $self->creator->resource ) if $self->creator;
+
+ push @{ $self->{content} }, $fact;
+ return $self;
}
# close just validates -- otherwise unnecessary
sub close {
- my ($self) = @_;
- my $class = ref $self;
+ my ($self) = @_;
+ my $class = ref $self;
- my $ok = eval { $self->validate_content; 1 };
- unless ($ok) {
- my $error = $@ || '(unknown error)';
- Carp::confess( "$class object content invalid: $error" );
- }
+ my $ok = eval { $self->validate_content; 1 };
+ unless ($ok) {
+ my $error = $@ || '(unknown error)';
+ Carp::confess("$class object content invalid: $error");
+ }
- $self->{__closed} = 1;
+ $self->{__closed} = 1;
- return $self;
+ return $self;
}
-# accessor for facts -- this must work regardless of __closed so
+# accessor for facts -- this must work regardless of __closed so
# that facts can be added using content_meta of facts already added
sub facts {
- my ($self) = @_;
- return @{ $self->content };
+ my ($self) = @_;
+ return @{ $self->content };
}
#--------------------------------------------------------------------------#
@@ -113,80 +115,81 @@ sub facts {
#--------------------------------------------------------------------------#
sub from_struct {
- my ($class, $struct) = @_;
- my $self = $class->SUPER::from_struct($struct);
- $self->{__closed} = 1;
- return $self;
+ my ( $class, $struct ) = @_;
+ my $self = $class->SUPER::from_struct($struct);
+ $self->{__closed} = 1;
+ return $self;
}
-sub content_as_bytes {
- my $self = shift;
+sub content_as_bytes {
+ my $self = shift;
- Carp::confess("can't serialize an open report") unless $self->{__closed};
+ Carp::confess("can't serialize an open report") unless $self->{__closed};
- my $content = [ map { $_->as_struct } @{ $self->content } ];
- my $encoded = eval { JSON->new->ascii->encode( $content ) };
- Carp::confess $@ if $@;
- return $encoded;
+ my $content = [ map { $_->as_struct } @{ $self->content } ];
+ my $encoded = eval { JSON->new->ascii->encode($content) };
+ Carp::confess $@ if $@;
+ return $encoded;
}
-sub content_from_bytes {
- my ($self, $string) = @_;
- $string = $$string if ref $string;
+sub content_from_bytes {
+ my ( $self, $string ) = @_;
+ $string = $$string if ref $string;
- my $fact_structs = JSON->new->ascii->decode( $string );
+ my $fact_structs = JSON->new->ascii->decode($string);
- my @facts;
- for my $struct (@$fact_structs) {
- my $class = $self->class_from_type( $struct->{metadata}{core}{type} );
- my $fact = eval { $class->from_struct($struct) }
- or Carp::confess "Unable to create a '$class' object: $@";
- push @facts, $fact;
- }
+ my @facts;
+ for my $struct (@$fact_structs) {
+ my $class = $self->class_from_type( $struct->{metadata}{core}{type} );
+ my $fact = eval { $class->from_struct($struct) }
+ or Carp::confess "Unable to create a '$class' object: $@";
+ push @facts, $fact;
+ }
- return \@facts;
+ return \@facts;
}
-# XXX what if spec is '0' (not '0+')? -- dagolden, 2009-03-30
+# XXX what if spec is '0' (not '0+')? -- dagolden, 2009-03-30
sub validate_content {
- my ($self) = @_;
-
- my $spec = $self->report_spec;
- my $content = $self->content;
-
- die ref $self . " content must be an array reference of Fact object"
- unless ref $content eq 'ARRAY';
-
- my @fact_matched;
- # check that each spec matches
- for my $k ( keys %$spec ) {
- $spec->{$k} =~ m{^(\d+)(\+)?$};
- my $minimum = defined $1 ? $1 : 0;
- my $exact = defined $2 ? 0 : 1; # exact unless "+"
- # mark facts that match a spec
- my $found = 0;
- for my $i ( 0 .. @$content - 1 ) {
- if ( $content->[$i]->isa( $k ) ) {
- $found++;
- $fact_matched[$i] = 1;
- }
+ my ($self) = @_;
+
+ my $spec = $self->report_spec;
+ my $content = $self->content;
+
+ die ref $self . " content must be an array reference of Fact object"
+ unless ref $content eq 'ARRAY';
+
+ my @fact_matched;
+ # check that each spec matches
+ for my $k ( keys %$spec ) {
+ $spec->{$k} =~ m{^(\d+)(\+)?$};
+ my $minimum = defined $1 ? $1 : 0;
+ my $exact = defined $2 ? 0 : 1; # exact unless "+"
+ # mark facts that match a spec
+ my $found = 0;
+ for my $i ( 0 .. @$content - 1 ) {
+ if ( $content->[$i]->isa($k) ) {
+ $found++;
+ $fact_matched[$i] = 1;
+ }
+ }
+
+ if ($exact) {
+ die "expected $minimum of $k, but found $found\n"
+ if $found != $minimum;
+ }
+ else {
+ die "expected at least $minimum of $k, but found $found\n"
+ if $found < $minimum;
+ }
}
- if ( $exact ) {
- die "expected $minimum of $k, but found $found\n"
- if $found != $minimum;
- } else {
- die "expected at least $minimum of $k, but found $found\n"
- if $found < $minimum;
- }
- }
+ # any facts that didn't match anything?
+ my $unmatched = grep { !$_ } @fact_matched;
+ die "$unmatched fact(s) not in the spec\n"
+ if $unmatched;
- # any facts that didn't match anything?
- my $unmatched = grep { ! $_ } @fact_matched;
- die "$unmatched fact(s) not in the spec\n"
- if $unmatched;
-
- return;
+ return;
}
#--------------------------------------------------------------------------#
@@ -194,32 +197,34 @@ sub validate_content {
#--------------------------------------------------------------------------#
sub fact_classes {
- my ($self) = @_;
- my $class = ref $self || $self;
- return keys %{ $self->report_spec }
+ my ($self) = @_;
+ my $class = ref $self || $self;
+ return keys %{ $self->report_spec };
}
sub load_fact_classes {
- my ($self) = @_;
- $self->_load_fact_class( $_ ) for $self->fact_classes;
- return;
+ my ($self) = @_;
+ $self->_load_fact_class($_) for $self->fact_classes;
+ return;
}
1;
# ABSTRACT: a base class for collections of Metabase facts
-
+__END__
=pod
+=encoding UTF-8
+
=head1 NAME
Metabase::Report - a base class for collections of Metabase facts
=head1 VERSION
-version 0.021
+version 0.024
=head1 SYNOPSIS
@@ -361,15 +366,10 @@ H.Merijn Brand <hmbrand@cpan.org>
=head1 COPYRIGHT AND LICENSE
-This software is Copyright (c) 2012 by David Golden.
+This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
-
-
-__END__
-
-
@@ -1,43 +1,44 @@
use 5.006;
use strict;
use warnings;
+
package Metabase::Resource::cpan::distfile;
-our $VERSION = '0.021'; # VERSION
+our $VERSION = '0.024'; # VERSION
-use Carp ();
+use Carp ();
use CPAN::DistnameInfo ();
use Metabase::Resource::cpan;
our @ISA = qw/Metabase::Resource::cpan/;
sub _metadata_types {
- return {
- cpan_id => '//str',
- dist_file => '//str',
- dist_name => '//str',
- dist_version => '//str',
- }
+ return {
+ cpan_id => '//str',
+ dist_file => '//str',
+ dist_name => '//str',
+ dist_version => '//str',
+ };
}
sub _init {
- my ($self) = @_;
-
- # determine subtype
- my ($string) = $self =~ m{\Acpan:///distfile/(.+)\z};
- Carp::confess("could not determine distfile from '$self'\n")
- unless defined $string && length $string;
-
- my $data = $self->_validate_distfile($string);
- for my $k ( keys %$data ) {
- $self->_add( $k => $data->{$k} );
- }
- return $self;
+ my ($self) = @_;
+
+ # determine subtype
+ my ($string) = $self =~ m{\Acpan:///distfile/(.+)\z};
+ Carp::confess("could not determine distfile from '$self'\n")
+ unless defined $string && length $string;
+
+ my $data = $self->_validate_distfile($string);
+ for my $k ( keys %$data ) {
+ $self->_add( $k => $data->{$k} );
+ }
+ return $self;
}
# distfile validates during _init, really
sub validate { 1 }
-# XXX should really validate AUTHOR/DISTNAME-DISTVERSION.SUFFIX
+# XXX should really validate AUTHOR/DISTNAME-DISTVERSION.SUFFIX
# -- dagolden, 2010-01-27
#
# my $suffix = qr{\.(?:tar\.(?:bz2|gz|Z)|t(?:gz|bz)|zip)};
@@ -47,48 +48,50 @@ sub validate { 1 }
# map DistnameInfo calls to our names
my %distfile_map = (
- cpanid => 'cpan_id',
- dist => 'dist_name',
- version => 'dist_version',
+ cpanid => 'cpan_id',
+ dist => 'dist_name',
+ version => 'dist_version',
);
sub _validate_distfile {
- my ($self, $string) = @_;
- my $two = substr($string,0,2);
- my $one = substr($two,0,1);
- my $path = "authors/id/$one/$two/$string";
- my $d = eval { CPAN::DistnameInfo->new($path) };
- my $bad = defined $d ? 0 : 1;
-
- my $cache = { dist_file => $string };
-
- for my $k ( $bad ? () : (keys %distfile_map) ) {
- my $value = $d->$k;
- defined $value or $bad++ and last;
- $cache->{$distfile_map{$k}} = $value
- }
-
- if ($bad) {
- Carp::confess("'$string' can't be parsed as a CPAN distfile");
- }
- return $cache;
+ my ( $self, $string ) = @_;
+ my $two = substr( $string, 0, 2 );
+ my $one = substr( $two, 0, 1 );
+ my $path = "authors/id/$one/$two/$string";
+ my $d = eval { CPAN::DistnameInfo->new($path) };
+ my $bad = defined $d ? 0 : 1;
+
+ my $cache = { dist_file => $string };
+
+ for my $k ( $bad ? () : ( keys %distfile_map ) ) {
+ my $value = $d->$k;
+ defined $value or $bad++ and last;
+ $cache->{ $distfile_map{$k} } = $value;
+ }
+
+ if ($bad) {
+ Carp::confess("'$string' can't be parsed as a CPAN distfile");
+ }
+ return $cache;
}
1;
# ABSTRACT: class for Metabase resources
-
+__END__
=pod
+=encoding UTF-8
+
=head1 NAME
Metabase::Resource::cpan::distfile - class for Metabase resources
=head1 VERSION
-version 0.021
+version 0.024
=head1 SYNOPSIS
@@ -146,17 +149,10 @@ H.Merijn Brand <hmbrand@cpan.org>
=head1 COPYRIGHT AND LICENSE
-This software is Copyright (c) 2012 by David Golden.
+This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
-
-
-__END__
-
-
-
-
@@ -1,8 +1,9 @@
use 5.006;
use strict;
use warnings;
+
package Metabase::Resource::cpan;
-our $VERSION = '0.021'; # VERSION
+our $VERSION = '0.024'; # VERSION
use Carp ();
@@ -10,28 +11,30 @@ use Metabase::Resource;
our @ISA = qw/Metabase::Resource/;
sub _extract_type {
- my ($self, $resource) = @_;
- my ($type) = $resource =~ m{\Acpan:///([^/]+)/};
- Carp::confess("could not determine Metabase::Resource type from '$resource'\n")
- unless defined $type && length $type;
- return __PACKAGE__ . "::$type";
+ my ( $self, $resource ) = @_;
+ my ($type) = $resource =~ m{\Acpan:///([^/]+)/};
+ Carp::confess("could not determine Metabase::Resource type from '$resource'\n")
+ unless defined $type && length $type;
+ return __PACKAGE__ . "::$type";
}
1;
# ABSTRACT: class for Metabase resources
-
+__END__
=pod
+=encoding UTF-8
+
=head1 NAME
Metabase::Resource::cpan - class for Metabase resources
=head1 VERSION
-version 0.021
+version 0.024
=head1 SYNOPSIS
@@ -93,15 +96,10 @@ H.Merijn Brand <hmbrand@cpan.org>
=head1 COPYRIGHT AND LICENSE
-This software is Copyright (c) 2012 by David Golden.
+This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
-
-
-__END__
-
-
@@ -1,8 +1,9 @@
use 5.006;
use strict;
use warnings;
+
package Metabase::Resource::metabase::fact;
-our $VERSION = '0.021'; # VERSION
+our $VERSION = '0.024'; # VERSION
use Carp ();
@@ -10,41 +11,41 @@ use Metabase::Resource::metabase;
our @ISA = qw/Metabase::Resource::metabase/;
sub _metadata_types {
- return {
- guid => '//str',
- };
+ return { guid => '//str', };
}
sub _init {
- my ($self) = @_;
- my ($guid) = $self =~ m{\Ametabase:[^:]+:(.+)\z};
- Carp::confess("could not determine guid from '$self'\n")
- unless defined $guid && length $guid;
- $self->_add( guid => $guid);
- return $self;
+ my ($self) = @_;
+ my ($guid) = $self =~ m{\Ametabase:[^:]+:(.+)\z};
+ Carp::confess("could not determine guid from '$self'\n")
+ unless defined $guid && length $guid;
+ $self->_add( guid => $guid );
+ return $self;
}
sub validate {
- my $self = shift;
- $self->_validate_guid( $self->guid );
- return 1;
+ my $self = shift;
+ $self->_validate_guid( $self->guid );
+ return 1;
}
1;
# ABSTRACT: class for Metabase facts
-
+__END__
=pod
+=encoding UTF-8
+
=head1 NAME
Metabase::Resource::metabase::fact - class for Metabase facts
=head1 VERSION
-version 0.021
+version 0.024
=head1 SYNOPSIS
@@ -96,15 +97,10 @@ H.Merijn Brand <hmbrand@cpan.org>
=head1 COPYRIGHT AND LICENSE
-This software is Copyright (c) 2012 by David Golden.
+This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
-
-
-__END__
-
-
@@ -1,9 +1,9 @@
use 5.006;
use strict;
use warnings;
-package Metabase::Resource::metabase::user;
-our $VERSION = '0.021'; # VERSION
+package Metabase::Resource::metabase::user;
+our $VERSION = '0.024'; # VERSION
use Metabase::Resource::metabase::fact;
our @ISA = qw/Metabase::Resource::metabase::fact/;
@@ -12,17 +12,19 @@ our @ISA = qw/Metabase::Resource::metabase::fact/;
# ABSTRACT: class for Metabase user profiles
-
+__END__
=pod
+=encoding UTF-8
+
=head1 NAME
Metabase::Resource::metabase::user - class for Metabase user profiles
=head1 VERSION
-version 0.021
+version 0.024
=head1 SYNOPSIS
@@ -74,16 +76,10 @@ H.Merijn Brand <hmbrand@cpan.org>
=head1 COPYRIGHT AND LICENSE
-This software is Copyright (c) 2012 by David Golden.
+This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
-
-
-__END__
-
-
-
@@ -1,50 +1,53 @@
use 5.006;
use strict;
use warnings;
+
package Metabase::Resource::metabase;
-our $VERSION = '0.021'; # VERSION
+our $VERSION = '0.024'; # VERSION
use Carp ();
use Metabase::Resource;
our @ISA = qw/Metabase::Resource/;
-my $hex = '[0-9a-f]';
+my $hex = '[0-9a-f]';
my $guid_re = qr(\A$hex{8}-$hex{4}-$hex{4}-$hex{4}-$hex{12}\z)i;
sub _validate_guid {
- my ($self, $string) = @_;
- if ( $string !~ $guid_re ) {
- Carp::confess("'$string' is not formatted as a GUID string");
- }
- return $string;
+ my ( $self, $string ) = @_;
+ if ( $string !~ $guid_re ) {
+ Carp::confess("'$string' is not formatted as a GUID string");
+ }
+ return $string;
}
sub _extract_type {
- my ($self, $resource) = @_;
+ my ( $self, $resource ) = @_;
- # determine type
- my ($type) = $resource =~ m{\Ametabase:([^:]+)};
- Carp::confess("could not determine URI type from '$resource'\n")
- unless defined $type && length $type;
- return __PACKAGE__ . "::$type";
+ # determine type
+ my ($type) = $resource =~ m{\Ametabase:([^:]+)};
+ Carp::confess("could not determine URI type from '$resource'\n")
+ unless defined $type && length $type;
+ return __PACKAGE__ . "::$type";
}
1;
# ABSTRACT: class for Metabase resources
-
+__END__
=pod
+=encoding UTF-8
+
=head1 NAME
Metabase::Resource::metabase - class for Metabase resources
=head1 VERSION
-version 0.021
+version 0.024
=head1 SYNOPSIS
@@ -118,15 +121,10 @@ H.Merijn Brand <hmbrand@cpan.org>
=head1 COPYRIGHT AND LICENSE
-This software is Copyright (c) 2012 by David Golden.
+This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
-
-
-__END__
-
-
@@ -1,8 +1,9 @@
use 5.006;
use strict;
use warnings;
+
package Metabase::Resource::perl::commit;
-our $VERSION = '0.021'; # VERSION
+our $VERSION = '0.024'; # VERSION
use Carp ();
@@ -10,53 +11,99 @@ use Metabase::Resource::perl;
our @ISA = qw/Metabase::Resource::perl/;
sub _metadata_types {
- return {
- sha1 => '//str',
- };
+ return { sha1 => '//str', };
}
sub _init {
- my ($self) = @_;
+ my ($self) = @_;
- my ($string) = $self =~ m{\Aperl:///commit/(.+)\z};
- Carp::confess("could not determine commit from '$self'\n")
- unless defined $string && length $string;
+ my ($string) = $self =~ m{\Aperl:///commit/(.+)\z};
+ Carp::confess("could not determine commit from '$self'\n")
+ unless defined $string && length $string;
- my $sha1 = $1;
- Carp::confess("illegal commit hash")
- unless $sha1 =~ m/^[a-f0-9]+$/;
+ my $sha1 = $1;
+ Carp::confess("illegal commit hash")
+ unless $sha1 =~ m/^[a-f0-9]+$/;
- $self->_add( 'sha1' => $sha1 );
+ $self->_add( 'sha1' => $sha1 );
- return $self;
+ return $self;
}
+# =method full_url
+#
+# my $url = $self->full_url($host);
+#
+# Returns an ordinary HTTP URL to the resource. If C<$host> is not
+# given, it defaults to the official master Perl repository at
+# L<http://perl5.git.perl.org>.
+#
+# =cut
sub full_url {
- my ($self, $host) = @_;
- $host ||= 'perl5.git.perl.org';
- return "http://${host}/perl.git/" . $self->sha1;
+ my ( $self, $host ) = @_;
+ $host ||= 'perl5.git.perl.org';
+ return "http://${host}/perl.git/" . $self->sha1;
}
# 'commit' validates during _init, really
sub validate { 1 }
+# =pod
+#
+# =head1 SYNOPSIS
+#
+# my $resource = Metabase::Resource->new(
+# 'perl:///commit/8c576062',
+# );
+#
+# my $resource_meta = $resource->metadata;
+# my $typemap = $resource->metadata_types;
+# my $url = $self->full_url;
+#
+# =head1 DESCRIPTION
+#
+# Generates resource metadata for resources of the scheme 'perl:///commit'.
+#
+# my $resource = Metabase::Resource->new(
+# 'perl:///commit/8c576062',
+# );
+#
+# For the example above, the resource metadata structure would contain the
+# following elements:
+#
+# scheme => perl
+# type => commit
+# sha1 => 8c576062
+#
+# =head1 BUGS
+#
+# Please report any bugs or feature using the CPAN Request Tracker.
+# Bugs can be submitted through the web interface at
+# L<http://rt.cpan.org/Dist/Display.html?Queue=Metabase-Fact>
+#
+# 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.
+#
+# =cut
1;
# ABSTRACT: class for Metabase resources about perl commits
-
+__END__
=pod
+=encoding UTF-8
+
=head1 NAME
Metabase::Resource::perl::commit - class for Metabase resources about perl commits
=head1 VERSION
-version 0.021
+version 0.024
=head1 SYNOPSIS
@@ -122,18 +169,10 @@ H.Merijn Brand <hmbrand@cpan.org>
=head1 COPYRIGHT AND LICENSE
-This software is Copyright (c) 2012 by David Golden.
+This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
-
-
-__END__
-
-
-
-
-
@@ -1,8 +1,9 @@
use 5.006;
use strict;
use warnings;
+
package Metabase::Resource::perl;
-our $VERSION = '0.021'; # VERSION
+our $VERSION = '0.024'; # VERSION
use Carp ();
@@ -10,35 +11,36 @@ use Metabase::Resource;
our @ISA = qw/Metabase::Resource/;
sub _extract_type {
- my ($self, $resource) = @_;
-
- # determine type
- # Possible types could be:
- # - commit
- # - tag -- not implemented
- # - tarball -- not implemented
- my ($type) = $resource =~ m{\Aperl:///([^/]+)/};
- Carp::confess("could not determine Metabase::Resource type from '$resource'\n")
- unless defined $type && length $type;
- return __PACKAGE__ . "::$type";
+ my ( $self, $resource ) = @_;
+
+ # determine type
+ # Possible types could be:
+ # - commit
+ # - tag -- not implemented
+ # - tarball -- not implemented
+ my ($type) = $resource =~ m{\Aperl:///([^/]+)/};
+ Carp::confess("could not determine Metabase::Resource type from '$resource'\n")
+ unless defined $type && length $type;
+ return __PACKAGE__ . "::$type";
}
1;
# ABSTRACT: class for Metabase resources under the perl scheme
-
-
__END__
+
=pod
+=encoding UTF-8
+
=head1 NAME
Metabase::Resource::perl - class for Metabase resources under the perl scheme
=head1 VERSION
-version 0.021
+version 0.024
=head1 SYNOPSIS
@@ -97,11 +99,10 @@ H.Merijn Brand <hmbrand@cpan.org>
=head1 COPYRIGHT AND LICENSE
-This software is Copyright (c) 2012 by David Golden.
+This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
-
@@ -1,8 +1,9 @@
use 5.006;
use strict;
use warnings;
+
package Metabase::Resource;
-our $VERSION = '0.021'; # VERSION
+our $VERSION = '0.024'; # VERSION
use Carp ();
@@ -10,101 +11,103 @@ use Carp ();
# main API methods -- shouldn't be overridden
#--------------------------------------------------------------------------#
-use overload ('""' => sub { $_[0]->resource },
- '==' => sub { _obj_eq(@_) },
- '!=' => sub { !_obj_eq(@_) },
- fallback => 1,
- );
+use overload (
+ '""' => sub { $_[0]->resource },
+ '==' => sub { _obj_eq(@_) },
+ '!=' => sub { !_obj_eq(@_) },
+ fallback => 1,
+);
# Check if two objects are the same object
sub _obj_eq {
- return overload::StrVal($_[0]) eq overload::StrVal($_[1]);
+ return overload::StrVal( $_[0] ) eq overload::StrVal( $_[1] );
}
-my $id_re = qr/[_a-z]+/i;
+my $id_re = qr/[_a-z]+/i;
my $class_re = qr/^$id_re(?:::$id_re)*$/;
+
sub _load {
- my ($class,$subclass) = @_;
- unless ( $subclass =~ $class_re ) {
- Carp::confess "'$subclass' does not look like a class name";
- }
- eval "require $subclass; 1" ## no critic
- or Carp::confess("Could not load '$subclass': $@");
+ my ( $class, $subclass ) = @_;
+ unless ( $subclass =~ $class_re ) {
+ Carp::confess "'$subclass' does not look like a class name";
+ }
+ eval "require $subclass; 1" ## no critic
+ or Carp::confess("Could not load '$subclass': $@");
}
my %installed;
sub _add {
- my ($self, $name, $value) = @_;
- $self->{metadata}{$name} = $value;
- my $method = ref($self) . "::$name";
- if ( ! $installed{$method} ) {
- no strict 'refs'; ## no critic
- *{$method} = sub { return $_[0]->{metadata}{$name} };
- $installed{$method}++;
- }
- return;
+ my ( $self, $name, $value ) = @_;
+ $self->{metadata}{$name} = $value;
+ my $method = ref($self) . "::$name";
+ if ( !$installed{$method} ) {
+ no strict 'refs'; ## no critic
+ *{$method} = sub { return $_[0]->{metadata}{$name} };
+ $installed{$method}++;
+ }
+ return;
}
sub _type {
- my ($self) = @_;
- my $class = ref $self || $self;
- $class =~ s{::}{-}g;
- return $class;
+ my ($self) = @_;
+ my $class = ref $self || $self;
+ $class =~ s{::}{-}g;
+ return $class;
}
sub new {
- my ($class, $resource) = @_;
- Carp::confess("no resource string provided")
- unless defined $resource && length $resource;
+ my ( $class, $resource ) = @_;
+ Carp::confess("no resource string provided")
+ unless defined $resource && length $resource;
- if ( ref $resource && eval {$resource->isa('Metabase::Resource')} ) {
- $resource = $resource->resource;
- }
+ if ( ref $resource && eval { $resource->isa('Metabase::Resource') } ) {
+ $resource = $resource->resource;
+ }
- # parse scheme
- my ($scheme) = $resource =~ m{\A([^:]+):};
- Carp::confess("could not determine URI scheme from '$resource'\n")
- unless defined $scheme && length $scheme;
-
- my $schema_class = "Metabase::Resource::$scheme";
- $class->_load($schema_class);
- my $type_class = $schema_class->_extract_type($resource);
- $class->_load($type_class);
-
- # construct object
- my $self = bless {
- resource => $resource,
- metadata => {},
- }, $type_class;
- if ( $self->can('_init') ) {
- $self->_init;
- }
+ # parse scheme
+ my ($scheme) = $resource =~ m{\A([^:]+):};
+ Carp::confess("could not determine URI scheme from '$resource'\n")
+ unless defined $scheme && length $scheme;
+
+ my $schema_class = "Metabase::Resource::$scheme";
+ $class->_load($schema_class);
+ my $type_class = $schema_class->_extract_type($resource);
+ $class->_load($type_class);
+
+ # construct object
+ my $self = bless {
+ resource => $resource,
+ metadata => {},
+ }, $type_class;
+ if ( $self->can('_init') ) {
+ $self->_init;
+ }
- $self->_add( type => $self->_type );
- $self->validate;
- return $self;
+ $self->_add( type => $self->_type );
+ $self->validate;
+ return $self;
}
# Don't cause segfault with perl-5.6.1 by
# overloading undef stuff...
sub resource {
- return '' unless ref $_[0] && defined $_[0]->{resource};
- return "$_[0]->{resource}";
+ return '' unless ref $_[0] && defined $_[0]->{resource};
+ return "$_[0]->{resource}";
}
# return a copy
sub metadata {
- my ($self) = @_;
- return { %{$self->{metadata} || {}} };
+ my ($self) = @_;
+ return { %{ $self->{metadata} || {} } };
}
sub metadata_types {
- my ($self) = @_;
- return {
- 'type' => '//str',
- %{$self->_metadata_types || {}}
- };
+ my ($self) = @_;
+ return {
+ 'type' => '//str',
+ %{ $self->_metadata_types || {} }
+ };
}
#--------------------------------------------------------------------------#
@@ -112,25 +115,27 @@ sub metadata_types {
#--------------------------------------------------------------------------#
sub validate {
- my ($self) = @_;
- Carp::confess "validate not implemented by " . (ref $self || $self)
+ my ($self) = @_;
+ Carp::confess "validate not implemented by " . ( ref $self || $self );
}
1;
# ABSTRACT: factory class for Metabase resource descriptors
-
+__END__
=pod
+=encoding UTF-8
+
=head1 NAME
Metabase::Resource - factory class for Metabase resource descriptors
=head1 VERSION
-version 0.021
+version 0.024
=head1 SYNOPSIS
@@ -208,7 +213,7 @@ of the URI into relevant index metadata.
Subclasses SHOULD NOT implement a C<new> constructor, as the Metabase::Resource
constructor will load the subclass, construct the object, bless the object
-into the subclass, and and then call C<validate> on the object. Subclasses
+into the subclass, and then call C<validate> on the object. Subclasses
MAY store structured data derived from the content string during validation.
Subclasses SHOULD use the C<content> method to access the resource string and
@@ -319,15 +324,10 @@ H.Merijn Brand <hmbrand@cpan.org>
=head1 COPYRIGHT AND LICENSE
-This software is Copyright (c) 2012 by David Golden.
+This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
-
-
-__END__
-
-
@@ -1,27 +1,30 @@
use 5.006;
use strict;
use warnings;
+
package Metabase::User::EmailAddress;
-our $VERSION = '0.021'; # VERSION
+our $VERSION = '0.024'; # VERSION
use Metabase::Fact::String;
our @ISA = qw/Metabase::Fact::String/;
-
+
1;
# ABSTRACT: Metabase fact for user email address
-
+__END__
=pod
+=encoding UTF-8
+
=head1 NAME
Metabase::User::EmailAddress - Metabase fact for user email address
=head1 VERSION
-version 0.021
+version 0.024
=head1 SYNOPSIS
@@ -67,14 +70,10 @@ H.Merijn Brand <hmbrand@cpan.org>
=head1 COPYRIGHT AND LICENSE
-This software is Copyright (c) 2012 by David Golden.
+This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
-
-
-__END__
-
@@ -1,27 +1,30 @@
use 5.006;
use strict;
use warnings;
+
package Metabase::User::FullName;
-our $VERSION = '0.021'; # VERSION
+our $VERSION = '0.024'; # VERSION
use Metabase::Fact::String;
our @ISA = qw/Metabase::Fact::String/;
-
+
1;
# ABSTRACT: Metabase fact for user full name
-
+__END__
=pod
+=encoding UTF-8
+
=head1 NAME
Metabase::User::FullName - Metabase fact for user full name
=head1 VERSION
-version 0.021
+version 0.024
=head1 SYNOPSIS
@@ -64,15 +67,10 @@ H.Merijn Brand <hmbrand@cpan.org>
=head1 COPYRIGHT AND LICENSE
-This software is Copyright (c) 2012 by David Golden.
+This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
-
-
-__END__
-
-
@@ -1,8 +1,9 @@
use 5.006;
use strict;
use warnings;
+
package Metabase::User::Profile;
-our $VERSION = '0.021'; # VERSION
+our $VERSION = '0.024'; # VERSION
use Carp ();
use Data::GUID guid_string => { -as => '_guid' };
@@ -17,30 +18,30 @@ __PACKAGE__->load_fact_classes;
#--------------------------------------------------------------------------#
sub create {
- my ($class, @args) = @_;
- my $args = $class->__validate_args(
- \@args,
- {
- full_name => 1,
- email_address => 1,
- }
- );
-
- # resource string must reference our own guid, so pregenerate it
- my $guid = lc _guid();
- my $profile = $class->open(
- guid => $guid,
- resource => "metabase:user:$guid",
- );
-
- # we are our own creator
- $profile->set_creator($profile->resource);
-
- # add facts
- $profile->add( 'Metabase::User::FullName' => $args->{full_name} );
- $profile->add( 'Metabase::User::EmailAddress' => $args->{email_address} );
- $profile->close;
- return $profile;
+ my ( $class, @args ) = @_;
+ my $args = $class->__validate_args(
+ \@args,
+ {
+ full_name => 1,
+ email_address => 1,
+ }
+ );
+
+ # resource string must reference our own guid, so pregenerate it
+ my $guid = lc _guid();
+ my $profile = $class->open(
+ guid => $guid,
+ resource => "metabase:user:$guid",
+ );
+
+ # we are our own creator
+ $profile->set_creator( $profile->resource );
+
+ # add facts
+ $profile->add( 'Metabase::User::FullName' => $args->{full_name} );
+ $profile->add( 'Metabase::User::EmailAddress' => $args->{email_address} );
+ $profile->close;
+ return $profile;
}
#--------------------------------------------------------------------------#
@@ -48,35 +49,37 @@ sub create {
#--------------------------------------------------------------------------#
sub validate_resource {
- my ($self) = shift;
- my $resource = $self->SUPER::validate_resource(@_);
- my ($guid) = $resource->guid;
- Carp::confess "resource guid differs from fact guid" if $guid ne $self->guid;
- return $resource;
+ my ($self) = shift;
+ my $resource = $self->SUPER::validate_resource(@_);
+ my ($guid) = $resource->guid;
+ Carp::confess "resource guid differs from fact guid" if $guid ne $self->guid;
+ return $resource;
}
-sub report_spec {
- return {
- 'Metabase::User::FullName' => '1',
- 'Metabase::User::EmailAddress' => '1+',
- }
+sub report_spec {
+ return {
+ 'Metabase::User::FullName' => '1',
+ 'Metabase::User::EmailAddress' => '1+',
+ };
}
-
+
1;
# ABSTRACT: Metabase report class for user-related facts
-
+__END__
=pod
+=encoding UTF-8
+
=head1 NAME
Metabase::User::Profile - Metabase report class for user-related facts
=head1 VERSION
-version 0.021
+version 0.024
=head1 SYNOPSIS
@@ -167,15 +170,10 @@ H.Merijn Brand <hmbrand@cpan.org>
=head1 COPYRIGHT AND LICENSE
-This software is Copyright (c) 2012 by David Golden.
+This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
-
-
-__END__
-
-
@@ -1,34 +1,37 @@
use 5.006;
use strict;
use warnings;
+
package Metabase::User::Secret;
-our $VERSION = '0.021'; # VERSION
+our $VERSION = '0.024'; # VERSION
use Metabase::Fact::String;
our @ISA = qw/Metabase::Fact::String/;
sub new {
- my $class = shift;
- my $self = $class->SUPER::new(@_);
- $self->set_creator($self->resource) unless $self->creator;
- return $self;
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+ $self->set_creator( $self->resource ) unless $self->creator;
+ return $self;
}
1;
# ABSTRACT: Metabase fact for user shared authentication secret
-
+__END__
=pod
+=encoding UTF-8
+
=head1 NAME
Metabase::User::Secret - Metabase fact for user shared authentication secret
=head1 VERSION
-version 0.021
+version 0.024
=head1 SYNOPSIS
@@ -71,16 +74,10 @@ H.Merijn Brand <hmbrand@cpan.org>
=head1 COPYRIGHT AND LICENSE
-This software is Copyright (c) 2012 by David Golden.
+This software is Copyright (c) 2014 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
-
-
-__END__
-
-
-
@@ -0,0 +1,26 @@
+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]
+
@@ -1,73 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use Test::More;
-
-
-
-use File::Find;
-use File::Temp qw{ tempdir };
-
-my @modules;
-find(
- sub {
- return if $File::Find::name !~ /\.pm\z/;
- my $found = $File::Find::name;
- $found =~ s{^lib/}{};
- $found =~ s{[/\\]}{::}g;
- $found =~ s/\.pm$//;
- # nothing to skip
- push @modules, $found;
- },
- 'lib',
-);
-
-sub _find_scripts {
- my $dir = shift @_;
-
- my @found_scripts = ();
- find(
- sub {
- return unless -f;
- my $found = $File::Find::name;
- # nothing to skip
- open my $FH, '<', $_ or do {
- note( "Unable to open $found in ( $! ), skipping" );
- return;
- };
- my $shebang = <$FH>;
- return unless $shebang =~ /^#!.*?\bperl\b\s*$/;
- push @found_scripts, $found;
- },
- $dir,
- );
-
- return @found_scripts;
-}
-
-my @scripts;
-do { push @scripts, _find_scripts($_) if -d $_ }
- for qw{ bin script scripts };
-
-my $plan = scalar(@modules) + scalar(@scripts);
-$plan ? (plan tests => $plan) : (plan skip_all => "no tests to run");
-
-{
- # fake home for cpan-testers
- local $ENV{HOME} = tempdir( CLEANUP => 1 );
-
- like( qx{ $^X -Ilib -e "require $_; print '$_ ok'" }, qr/^\s*$_ ok/s, "$_ loaded ok" )
- for sort @modules;
-
- SKIP: {
- eval "use Test::Script 1.05; 1;";
- skip "Test::Script needed to test script compilation", scalar(@scripts) if $@;
- foreach my $file ( @scripts ) {
- my $script = $file;
- $script =~ s!.*/!!;
- script_compiles( $file, "$script script compiles" );
- }
- }
-}
@@ -0,0 +1,191 @@
+#!perl
+
+use strict;
+use warnings;
+
+# This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.013
+
+use Test::More tests => 1;
+
+use ExtUtils::MakeMaker;
+use File::Spec::Functions;
+use List::Util qw/max/;
+use version;
+
+# hide optional CPAN::Meta modules from prereq scanner
+# and check if they are available
+my $cpan_meta = "CPAN::Meta";
+my $cpan_meta_req = "CPAN::Meta::Requirements";
+my $HAS_CPAN_META = eval "require $cpan_meta"; ## no critic
+my $HAS_CPAN_META_REQ = eval "require $cpan_meta_req; $cpan_meta_req->VERSION('2.120900')";
+
+# Verify requirements?
+my $DO_VERIFY_PREREQS = 1;
+
+sub _merge_requires {
+ my ($collector, $prereqs) = @_;
+ for my $phase ( qw/configure build test runtime develop/ ) {
+ next unless exists $prereqs->{$phase};
+ if ( my $req = $prereqs->{$phase}{'requires'} ) {
+ my $cmr = CPAN::Meta::Requirements->from_string_hash( $req );
+ $collector->add_requirements( $cmr );
+ }
+ }
+}
+
+my %include = map {; $_ => 1 } qw(
+
+);
+
+my %exclude = map {; $_ => 1 } qw(
+
+);
+
+# Add static prereqs to the included modules list
+my $static_prereqs = do { my $x = {
+ 'configure' => {
+ 'requires' => {
+ 'ExtUtils::MakeMaker' => '6.17'
+ }
+ },
+ 'develop' => {
+ 'requires' => {
+ 'Dist::Zilla' => '5.013',
+ 'Dist::Zilla::PluginBundle::DAGOLDEN' => '0.060',
+ 'File::Spec' => '0',
+ 'File::Temp' => '0',
+ 'IO::Handle' => '0',
+ 'IPC::Open3' => '0',
+ 'Pod::Coverage::TrustPod' => '0',
+ 'Test::CPAN::Meta' => '0',
+ 'Test::More' => '0',
+ 'Test::Pod' => '1.41',
+ 'Test::Pod::Coverage' => '1.08'
+ }
+ },
+ 'runtime' => {
+ 'requires' => {
+ 'CPAN::DistnameInfo' => '0',
+ 'Carp' => '0',
+ 'Data::GUID' => '0',
+ 'Getopt::Long' => '0',
+ 'IO::Prompt::Tiny' => '0',
+ 'JSON' => '2',
+ 'Pod::Usage' => '0',
+ 'overload' => '0',
+ 'perl' => '5.006',
+ 'strict' => '0',
+ 'warnings' => '0'
+ }
+ },
+ 'test' => {
+ 'recommends' => {
+ 'CPAN::Meta' => '0',
+ 'CPAN::Meta::Requirements' => '2.120900'
+ },
+ 'requires' => {
+ 'Cwd' => '0',
+ 'ExtUtils::MakeMaker' => '0',
+ 'File::Spec' => '0',
+ 'File::Spec::Functions' => '0',
+ 'File::Temp' => '0.20',
+ 'List::Util' => '0',
+ 'Test::Fatal' => '0',
+ 'Test::More' => '0.88',
+ 'lib' => '0',
+ 'version' => '0'
+ }
+ }
+ };
+ $x;
+ };
+
+delete $static_prereqs->{develop} if not $ENV{AUTHOR_TESTING};
+$include{$_} = 1 for map { keys %$_ } map { values %$_ } values %$static_prereqs;
+
+# Merge requirements for major phases (if we can)
+my $all_requires;
+if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META_REQ ) {
+ $all_requires = $cpan_meta_req->new;
+ _merge_requires($all_requires, $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 ) {
+ if ( my $meta = eval { CPAN::Meta->load_file($source) } ) {
+ my $dynamic_prereqs = $meta->prereqs;
+ delete $dynamic_prereqs->{develop} if not $ENV{AUTHOR_TESTING};
+ $include{$_} = 1 for map { keys %$_ } map { values %$_ } values %$dynamic_prereqs;
+
+ if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META_REQ ) {
+ _merge_requires($all_requires, $dynamic_prereqs);
+ }
+ }
+}
+else {
+ $source = 'static metadata';
+}
+
+my @modules = sort grep { ! $exclude{$_} } keys %include;
+my @reports = [qw/Version Module/];
+my @dep_errors;
+my $req_hash = defined($all_requires) ? $all_requires->as_string_hash : {};
+
+for my $mod ( @modules ) {
+ next if $mod eq 'perl';
+ my $file = $mod;
+ $file =~ s{::}{/}g;
+ $file .= ".pm";
+ my ($prefix) = grep { -e catfile($_, $file) } @INC;
+ if ( $prefix ) {
+ my $ver = MM->parse_version( catfile($prefix, $file) );
+ $ver = "undef" unless defined $ver; # Newer MM should do this anyway
+ push @reports, [$ver, $mod];
+
+ if ( $DO_VERIFY_PREREQS && $all_requires ) {
+ my $req = $req_hash->{$mod};
+ if ( defined $req && length $req ) {
+ if ( ! defined eval { version->parse($ver) } ) {
+ push @dep_errors, "$mod version '$ver' cannot be parsed (version '$req' required)";
+ }
+ elsif ( ! $all_requires->accepts_module( $mod => $ver ) ) {
+ push @dep_errors, "$mod version '$ver' is not in required range '$req'";
+ }
+ }
+ }
+
+ }
+ else {
+ push @reports, ["missing", $mod];
+
+ if ( $DO_VERIFY_PREREQS && $all_requires ) {
+ my $req = $req_hash->{$mod};
+ if ( defined $req && length $req ) {
+ push @dep_errors, "$mod is not installed (version '$req' required)";
+ }
+ }
+ }
+}
+
+if ( @reports ) {
+ my $vl = max map { length $_->[0] } @reports;
+ my $ml = max map { length $_->[1] } @reports;
+ splice @reports, 1, 0, ["-" x $vl, "-" x $ml];
+ diag "\nVersions for all modules listed in $source (including optional ones):\n",
+ map {sprintf(" %*s %*s\n",$vl,$_->[0],-$ml,$_->[1])} @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:
@@ -1,59 +1,52 @@
# Copyright (c) 2008 by Ricardo Signes. All rights reserved.
# Licensed under terms of Perl itself (the "License").
# You may not use this file except in compliance with the License.
-# A copy of the License was distributed with this file or you may obtain a
+# A copy of the License was distributed with this file or you may obtain a
# copy of the License from http://dev.perl.org/licenses/
use strict;
use warnings;
use Test::More 0.88;
-use Test::Exception;
+use Test::Fatal;
use lib 't/lib';
use Test::Metabase::StringFact;
plan tests => 17;
-require_ok( 'Metabase::Fact' );
+require_ok('Metabase::Fact');
#--------------------------------------------------------------------------#
# fixtures
-#--------------------------------------------------------------------------#
+#--------------------------------------------------------------------------#
-my ($obj, $err);
+my ( $obj, $err );
#--------------------------------------------------------------------------#
# required parameters missing
#--------------------------------------------------------------------------#
-eval { $obj = Metabase::Fact->new() };
-$err = $@;
+$err = exception { $obj = Metabase::Fact->new() };
like( $err, qr/missing required/, "new() without params throws error" );
-for my $p ( qw/ resource content / ) {
+for my $p (qw/ resource content /) {
like( $err, qr/$p/, "... '$p' noted missing" );
}
-is(
- Metabase::Fact->default_schema_version,
- 1,
- "schema_version() defaults to 1",
-);
+is( Metabase::Fact->default_schema_version, 1, "schema_version() defaults to 1", );
#--------------------------------------------------------------------------#
# fake an object and test methods
#--------------------------------------------------------------------------#
# type is class munged from "::" to "-"
-is( Metabase::Fact->type, "Metabase-Fact",
- "->type converts class name"
-);
+is( Metabase::Fact->type, "Metabase-Fact", "->type converts class name" );
# unimplemented
-for my $m ( qw/content_as_bytes content_from_bytes validate_content/ ) {
+for my $m (qw/content_as_bytes content_from_bytes validate_content/) {
my $obj = bless {} => 'Metabase::Fact';
- eval { $obj->$m };
- like( $@, qr/$m not implemented by Metabase::Fact/, "$m not implemented");
+ $err = exception { $obj->$m };
+ like( $err, qr/$m not implemented by Metabase::Fact/, "$m not implemented" );
}
#--------------------------------------------------------------------------#
@@ -67,13 +60,13 @@ my $args = {
content => $string,
};
-lives_ok{ $obj = Test::Metabase::StringFact->new( $args ) }
- "new( <hashref> ) doesn't die";
+is exception { $obj = Test::Metabase::StringFact->new($args) }, undef,
+"new( <hashref> ) doesn't die";
-isa_ok( $obj, 'Test::Metabase::StringFact' );
+isa_ok( $obj, 'Test::Metabase::StringFact' );
-lives_ok{ $obj = Test::Metabase::StringFact->new( %$args ) }
- "new( <list> ) doesn't die";
+is exception { $obj = Test::Metabase::StringFact->new(%$args) }, undef,
+"new( <list> ) doesn't die";
isa_ok( $obj, 'Test::Metabase::StringFact' );
@@ -84,13 +77,16 @@ is( $obj->content, $string, "object content correct" );
# class validation
#--------------------------------------------------------------------------#
-eval { $obj->_load_fact_class("Cwd;die 'Insecure'!"); };
-like( $@, qr/does not look like a class name/,
- "fact class loading validates class name"
+$err = exception { $obj->_load_fact_class("Cwd;die 'Insecure'!"); };
+like(
+ $err,
+ qr/does not look like a class name/,
+ "fact class loading validates class name"
);
-eval { $obj->resource->_load("Cwd;die 'Insecure'!"); };
-like( $@, qr/does not look like a class name/,
- "fact class loading validates class name"
+$err = exception { $obj->resource->_load("Cwd;die 'Insecure'!"); };
+like(
+ $err,
+ qr/does not look like a class name/,
+ "fact class loading validates class name"
);
-
@@ -9,14 +9,14 @@ use warnings;
use Data::GUID qw/guid_string/;
use Test::More;
-use Test::Exception;
+use Test::Fatal;
use JSON 2 ();
use lib 't/lib';
plan tests => 23;
-require_ok( 'FactSubclasses.pm' );
+require_ok('FactSubclasses.pm');
#--------------------------------------------------------------------------#
# fixtures
@@ -24,85 +24,83 @@ require_ok( 'FactSubclasses.pm' );
my $json = JSON->new->ascii;
-my ($obj, $err);
+my ( $obj, $err );
my $struct = {
- first => 'alpha',
- second => 'beta',
+ first => 'alpha',
+ second => 'beta',
};
-my $meta = {
- size => [ '//num' => 2 ],
-};
+my $meta = { size => [ '//num' => 2 ], };
my $args = {
- resource => "cpan:///distfile/JOHNDOE/Foo-Bar-1.23.tar.gz",
- content => $struct,
+ resource => "cpan:///distfile/JOHNDOE/Foo-Bar-1.23.tar.gz",
+ content => $struct,
};
my $test_args = {
- resource => $args->{resource},
- content => { },
+ resource => $args->{resource},
+ content => {},
};
-eval { $obj = FactFour->new( $test_args ) };
-like( $@, qr/missing required keys.+?first/, 'missing required dies');
+$err = exception { $obj = FactFour->new($test_args) };
+like( $err, qr/missing required keys.+?first/, 'missing required dies' );
$test_args->{content}{first} = undef;
-lives_ok{ $obj = FactFour->new( $test_args ) }
- "undef required field is OK";
+is exception { $obj = FactFour->new($test_args) }, undef, "undef required field is OK";
$test_args->{content}{first} = 1;
-lives_ok{ $obj = FactFour->new( $test_args ) }
- "new( <hashref> ) doesn't die";
+is exception { $obj = FactFour->new($test_args) }, undef, "new( <hashref> ) doesn't die";
$test_args->{content}{third} = 3;
-eval { $obj = FactFour->new( $test_args ) };
-like( $@, qr/invalid keys.+?third/, 'invalid key dies');
+$err = exception { $obj = FactFour->new($test_args) };
+like( $err, qr/invalid keys.+?third/, 'invalid key dies' );
isa_ok( $obj, 'Metabase::Fact::Hash' );
-lives_ok{ $obj = FactFour->new( %$args ) }
- "new( <list> ) doesn't die";
+is exception { $obj = FactFour->new(%$args) }, undef, "new( <list> ) doesn't die";
isa_ok( $obj, 'Metabase::Fact::Hash' );
ok( $obj->guid, "object has a GUID" );
-is( $obj->type, "FactFour", "object type is correct" );
+is( $obj->type, "FactFour", "object type is correct" );
is( $obj->{metadata}{core}{type}, "FactFour", "object type is set internally" );
is( $obj->resource, $args->{resource}, "object refers to distribution" );
-is_deeply( $obj->content_metadata, $meta, "object content_metadata() correct" );
-is_deeply( $obj->content, $struct, "object content correct" );
+is_deeply( $obj->content_metadata, $meta, "object content_metadata() correct" );
+is_deeply( $obj->content, $struct, "object content correct" );
my $want_struct = {
- content => $json->encode($struct),
- metadata => {
- core => {
- type => 'FactFour' ,
- schema_version => 1 ,
- guid => $obj->guid ,
- resource => $args->{resource},
- valid => 1 ,
- },
- }
+ content => $json->encode($struct),
+ metadata => {
+ core => {
+ type => 'FactFour',
+ schema_version => 1,
+ guid => $obj->guid,
+ resource => $args->{resource},
+ valid => 1,
+ },
+ }
};
my $have_struct = $obj->as_struct;
-is( $have_struct->{metadata}{core}{update_time},
+is(
+ $have_struct->{metadata}{core}{update_time},
$have_struct->{metadata}{core}{creation_time},
"creation_time equals update_time"
);
my $creation_time = delete $have_struct->{metadata}{core}{creation_time};
-like( $creation_time, qr/\A\d\d\d\d-\d\d-\d\dT\d\d:\d\d:\d\dZ\z/,
- 'creation_time is ISO 8601 Zulu',
+like(
+ $creation_time,
+ qr/\A\d\d\d\d-\d\d-\d\dT\d\d:\d\d:\d\dZ\z/,
+ 'creation_time is ISO 8601 Zulu',
);
delete $have_struct->{metadata}{core}{update_time};
-is_deeply($have_struct, $want_struct, "object as_struct correct");
+is_deeply( $have_struct, $want_struct, "object as_struct correct" );
my $creator_uri = 'metabase:user:351e99ea-1d21-11de-ab9c-3268421c7a0a';
$obj->set_creator($creator_uri);
@@ -111,37 +109,34 @@ $want_struct->{metadata}{core}{creator} = Metabase::Resource->new($creator_uri);
$have_struct = $obj->as_struct;
delete $have_struct->{metadata}{core}{update_time};
delete $have_struct->{metadata}{core}{creation_time};
-is_deeply($have_struct, $want_struct, "object as_struct correct w/creator");
+is_deeply( $have_struct, $want_struct, "object as_struct correct w/creator" );
$obj->set_valid(0);
$want_struct->{metadata}{core}{valid} = 0;
$have_struct = $obj->as_struct;
delete $have_struct->{metadata}{core}{update_time};
delete $have_struct->{metadata}{core}{creation_time};
-is_deeply($have_struct, $want_struct, "set_valid(0)");
+is_deeply( $have_struct, $want_struct, "set_valid(0)" );
$obj->set_valid(2);
$want_struct->{metadata}{core}{valid} = 1;
$have_struct = $obj->as_struct;
delete $have_struct->{metadata}{core}{update_time};
delete $have_struct->{metadata}{core}{creation_time};
-is_deeply($have_struct, $want_struct, "set_valid(2) normalized to '1'");
+is_deeply( $have_struct, $want_struct, "set_valid(2) normalized to '1'" );
#--------------------------------------------------------------------------#
-$obj = FactFour->new( %$args );
+$obj = FactFour->new(%$args);
my $obj2 = FactFour->from_struct( $obj->as_struct );
is_deeply( $obj2, $obj, "roundtrip as->from struct" );
#--------------------------------------------------------------------------#
{
- my $guid = uc guid_string;
- $obj = FactFour->new( %$args, guid => $guid );
- ok( $obj, "got object (set upper case guid manually)" );
- is( $obj->guid, lc $guid, "object has correct lower-case guid" );
+ my $guid = uc guid_string;
+ $obj = FactFour->new( %$args, guid => $guid );
+ ok( $obj, "got object (set upper case guid manually)" );
+ is( $obj->guid, lc $guid, "object has correct lower-case guid" );
}
-
-
-
@@ -1,46 +1,43 @@
# Copyright (c) 2008 by Ricardo Signes. All rights reserved.
# Licensed under terms of Perl itself (the "License").
# You may not use this file except in compliance with the License.
-# A copy of the License was distributed with this file or you may obtain a
+# A copy of the License was distributed with this file or you may obtain a
# copy of the License from http://dev.perl.org/licenses/
use strict;
use warnings;
use Test::More;
-use Test::Exception;
+use Test::Fatal;
use lib 't/lib';
plan tests => 12;
-require_ok( 'FactSubclasses.pm' );
+require_ok('FactSubclasses.pm');
#--------------------------------------------------------------------------#
# fixtures
-#--------------------------------------------------------------------------#
+#--------------------------------------------------------------------------#
-my ($obj, $err);
+my ( $obj, $err );
my $string = "Who am I?";
-my $meta = {
- 'length' => [ '//num' => length $string ],
-};
+my $meta = { 'length' => [ '//num' => length $string ], };
my $args = {
resource => "cpan:///distfile/JOHNDOE/Foo-Bar-1.23.tar.gz",
content => $string,
};
-lives_ok{ $obj = FactThree->new( $args ) }
- "new( <hashref> ) doesn't die";
+is exception { $obj = FactThree->new($args) }, undef, "new( <hashref> ) doesn't die";
-isa_ok( $obj, 'Metabase::Fact::String' );
+isa_ok( $obj, 'Metabase::Fact::String' );
my $test_guid = "b4ac3de6-15bb-11df-b44d-0018f34ec37c";
-lives_ok{ $obj = FactThree->new( %$args, guid => $test_guid ) }
- "new( <list> ) doesn't die";
+is exception { $obj = FactThree->new( %$args, guid => $test_guid ) }, undef,
+"new( <list> ) doesn't die";
isa_ok( $obj, 'Metabase::Fact::String' );
is( $obj->type, "FactThree", "object type is correct" );
@@ -50,29 +47,32 @@ is_deeply( $obj->content_metadata, $meta, "object content_metadata() correct" );
is( $obj->content, $string, "object content correct" );
my $want_struct = {
- content => $string,
- metadata => {
- core => {
- type => 'FactThree' ,
- schema_version => 1 ,
- guid => $test_guid ,
- resource => $args->{resource} ,
- valid => 1 ,
+ content => $string,
+ metadata => {
+ core => {
+ type => 'FactThree',
+ schema_version => 1,
+ guid => $test_guid,
+ resource => $args->{resource},
+ valid => 1,
+ },
},
- },
};
my $have_struct = $obj->as_struct;
-is( $have_struct->{metadata}{core}{update_time},
+is(
+ $have_struct->{metadata}{core}{update_time},
$have_struct->{metadata}{core}{creation_time},
"creation_time equals update_time"
);
my $creation_time = delete $have_struct->{metadata}{core}{creation_time};
-like( $creation_time, qr/\A\d\d\d\d-\d\d-\d\dT\d\d:\d\d:\d\dZ\z/,
- 'creation_time is ISO 8601 Zulu',
+like(
+ $creation_time,
+ qr/\A\d\d\d\d-\d\d-\d\dT\d\d:\d\d:\d\dZ\z/,
+ 'creation_time is ISO 8601 Zulu',
);
-delete $have_struct->{metadata}{core}{update_time};
+delete $have_struct->{metadata}{core}{update_time};
-is_deeply($have_struct, $want_struct, "object as_struct() correct");
+is_deeply( $have_struct, $want_struct, "object as_struct() correct" );
@@ -7,31 +7,33 @@ use Metabase::Fact::Hash;
package FactOne;
our @ISA = ('Metabase::Fact::String');
-sub content_as_bytes { return reverse($_[0]->{content}) };
-sub content_from_bytes { return reverse($_[1]) };
+sub content_as_bytes { return reverse( $_[0]->{content} ) }
+sub content_from_bytes { return reverse( $_[1] ) }
package FactTwo;
our @ISA = ('Metabase::Fact::String');
-sub content_as_bytes { return reverse($_[0]->{content}) };
-sub content_from_bytes { return reverse($_[1]) };
+sub content_as_bytes { return reverse( $_[0]->{content} ) }
+sub content_from_bytes { return reverse( $_[1] ) }
package FactThree;
our @ISA = ('Metabase::Fact::String');
-sub validate_content {
- $_[0]->SUPER::validate_content;
- die "content not positive length" unless length $_[0]->content > 0;
+
+sub validate_content {
+ $_[0]->SUPER::validate_content;
+ die "content not positive length" unless length $_[0]->content > 0;
}
-sub content_metadata {
- return { 'length' => [ '//num' => length $_[0]->content ] }
+
+sub content_metadata {
+ return { 'length' => [ '//num' => length $_[0]->content ] };
}
package FactFour;
our @ISA = ('Metabase::Fact::Hash');
-sub required_keys {qw/ first /};
-sub optional_keys {qw/ second /};
-sub content_metadata {
- return { 'size' => [ '//num' => scalar keys %{ $_[0]->content } ] }
-}
+sub required_keys { qw/ first / }
+sub optional_keys { qw/ second / }
+sub content_metadata {
+ return { 'size' => [ '//num' => scalar keys %{ $_[0]->content } ] };
+}
1;
@@ -3,28 +3,30 @@ use warnings;
package JustOneFact;
our @ISA = ('Metabase::Report');
-sub report_spec { return {'Metabase::Fact' => 1} }
+sub report_spec { return { 'Metabase::Fact' => 1 } }
package OneOrMoreFacts;
our @ISA = ('Metabase::Report');
-sub report_spec { return {'Metabase::Fact' => '1+'} }
+sub report_spec { return { 'Metabase::Fact' => '1+' } }
package OneOfEach;
our @ISA = ('Metabase::Report');
-sub report_spec {
- return {
- 'FactOne' => '1',
- 'FactTwo' => '1',
- }
+
+sub report_spec {
+ return {
+ 'FactOne' => '1',
+ 'FactTwo' => '1',
+ };
}
package OneSpecificAtLeastThreeTotal;
our @ISA = ('Metabase::Report');
-sub report_spec {
- return {
- 'FactOne' => '1',
- 'Metabase::Fact' => '3',
- }
+
+sub report_spec {
+ return {
+ 'FactOne' => '1',
+ 'Metabase::Fact' => '3',
+ };
}
1;
@@ -6,17 +6,15 @@ use Metabase::Fact::String;
our @ISA = qw/Metabase::Fact::String/;
sub content_metadata {
- my $self = shift;
- return {
- 'size' => [ '//num' => length $self->content ],
- };
+ my $self = shift;
+ return { 'size' => [ '//num' => length $self->content ], };
}
sub validate_content {
- my $self = shift;
- $self->SUPER::validate_content;
- die __PACKAGE__ . " content length must be greater than zero\n"
- if length $self->content < 0;
+ my $self = shift;
+ $self->SUPER::validate_content;
+ die __PACKAGE__ . " content length must be greater than zero\n"
+ if length $self->content < 0;
}
1;
@@ -1,56 +1,57 @@
# Copyright (c) 2008 by Ricardo Signes. All rights reserved.
# Licensed under terms of Perl itself (the "License").
# You may not use this file except in compliance with the License.
-# A copy of the License was distributed with this file or you may obtain a
+# A copy of the License was distributed with this file or you may obtain a
# copy of the License from http://dev.perl.org/licenses/
use strict;
use warnings;
use Test::More;
-use Test::Exception;
+use Test::Fatal;
use lib 't/lib';
plan tests => 13;
-require_ok( 'Metabase::Report' );
-require_ok( 'Test::Metabase::StringFact' );
+require_ok('Metabase::Report');
+require_ok('Test::Metabase::StringFact');
#--------------------------------------------------------------------------#
# fixtures
-#--------------------------------------------------------------------------#
+#--------------------------------------------------------------------------#
require ReportSubclasses;
require FactSubclasses;
-my %params = (
- resource => "cpan:///distfile/JOHNDOE/Foo-Bar-1.23.tar.gz",
-);
+my %params = ( resource => "cpan:///distfile/JOHNDOE/Foo-Bar-1.23.tar.gz", );
my %facts = (
- FactOne => FactOne->new( %params, content => "FactOne" ),
- FactTwo => FactTwo->new( %params, content => "FactTwo" ),
+ FactOne => FactOne->new( %params, content => "FactOne" ),
+ FactTwo => FactTwo->new( %params, content => "FactTwo" ),
);
-my ($report, $err);
+my ( $report, $err );
#--------------------------------------------------------------------------#
# report that takes 1 fact
#--------------------------------------------------------------------------#
-lives_ok {
- $report = JustOneFact->open( %params )
-} "lives: open() given no facts";
+is exception {
+ $report = JustOneFact->open(%params);
+}, undef,
+": open() given no facts";
isa_ok( $report, 'JustOneFact' );
-lives_ok {
- $report->add( 'FactOne' => 'This is FactOne' );
-} "lives: add( 'Class' => 'foo' )";
+is exception {
+ $report->add( 'FactOne' => 'This is FactOne' );
+}, undef,
+"lives: add( 'Class' => 'foo' )";
-lives_ok {
- $report->close;
-} "lives: close()";
+is exception {
+ $report->close;
+}, undef,
+"lives: close()";
#--------------------------------------------------------------------------#
# round trip
@@ -59,23 +60,24 @@ lives_ok {
my $class = ref $report;
my $report2;
-lives_ok {
- $report2 = $class->from_struct( $report->as_struct );
-} "lives: as_struct->from_struct";
+is exception {
+ $report2 = $class->from_struct( $report->as_struct );
+}, undef,
+"lives: as_struct->from_struct";
isa_ok( $report2, $class );
-
+
is_deeply( $report, $report2, "report2 is a clone of report" );
# set_creator
-for my $fact ($report, $report->facts) {
- is($fact->creator, undef, "no creator (round 1)");
+for my $fact ( $report, $report->facts ) {
+ is( $fact->creator, undef, "no creator (round 1)" );
}
my $creator_uri = 'metabase:user:351e99ea-1d21-11de-ab9c-3268421c7a0a';
$report->set_creator($creator_uri);
-for my $fact ($report, $report->facts) {
- is($fact->creator, $creator_uri, "creator set properly (round 2)");
+for my $fact ( $report, $report->facts ) {
+ is( $fact->creator, $creator_uri, "creator set properly (round 2)" );
}
@@ -1,90 +1,87 @@
# Copyright (c) 2008 by Ricardo Signes. All rights reserved.
# Licensed under terms of Perl itself (the "License").
# You may not use this file except in compliance with the License.
-# A copy of the License was distributed with this file or you may obtain a
+# A copy of the License was distributed with this file or you may obtain a
# copy of the License from http://dev.perl.org/licenses/
use strict;
use warnings;
use Test::More;
-use Test::Exception;
+use Test::Fatal;
use lib 't/lib';
plan tests => 9;
-require_ok( 'Metabase::Report' );
-require_ok( 'Test::Metabase::StringFact' );
+require_ok('Metabase::Report');
+require_ok('Test::Metabase::StringFact');
#--------------------------------------------------------------------------#
# fixtures
-#--------------------------------------------------------------------------#
+#--------------------------------------------------------------------------#
require ReportSubclasses;
require FactSubclasses;
-my %params = (
- resource => "cpan:///distfile/JOHNDOE/Foo-Bar-1.23.tar.gz",
-);
+my %params = ( resource => "cpan:///distfile/JOHNDOE/Foo-Bar-1.23.tar.gz", );
my %facts = (
- FactOne => FactOne->new( %params, content => "FactOne" ),
- FactTwo => FactTwo->new( %params, content => "FactTwo" ),
+ FactOne => FactOne->new( %params, content => "FactOne" ),
+ FactTwo => FactTwo->new( %params, content => "FactTwo" ),
);
-my ($obj, $err);
+my ( $obj, $err );
#--------------------------------------------------------------------------#
# report that takes 1 fact
#--------------------------------------------------------------------------#
-lives_ok {
+is exception {
$obj = JustOneFact->new( %params, content => [ $facts{FactOne} ] );
-} "lives: new() takes 1 fact, and given 1 fact";
+}, undef,
+"lives: new() takes 1 fact, and given 1 fact";
-dies_ok {
- $obj = JustOneFact->new( %params, content => [ ] );
-} "dies: new() takes 1 fact, but given none";
+isnt exception {
+ $obj = JustOneFact->new( %params, content => [] );
+}, undef,
+"dies: new() takes 1 fact, but given none";
-dies_ok {
- $obj = JustOneFact->new( %params,
- content => [ @facts{qw/FactOne FactTwo/} ]
- );
-} "dies: new() takes 1 fact, but given 2 facts";
+isnt exception {
+ $obj = JustOneFact->new( %params, content => [ @facts{qw/FactOne FactTwo/} ] );
+}, undef,
+"dies: new() takes 1 fact, but given 2 facts";
#--------------------------------------------------------------------------#
# report that takes 1+ facts
#--------------------------------------------------------------------------#
-lives_ok {
- $obj = OneOrMoreFacts->new( %params,
- content => [ @facts{qw/FactOne FactTwo/} ]
- );
-} "lives: new() takes 1+ fact, and given 2 facts";
+is exception {
+ $obj = OneOrMoreFacts->new( %params, content => [ @facts{qw/FactOne FactTwo/} ] );
+}, undef,
+"lives: new() takes 1+ fact, and given 2 facts";
#--------------------------------------------------------------------------#
# report that takes 1 of each
#--------------------------------------------------------------------------#
-lives_ok {
- $obj = OneOfEach->new( %params,
- content => [ @facts{qw/FactOne FactTwo/} ]
- );
-} "lives: new() takes 1 of each, given 1 of each";
+is exception {
+ $obj = OneOfEach->new( %params, content => [ @facts{qw/FactOne FactTwo/} ] );
+}, undef,
+"lives: new() takes 1 of each, given 1 of each";
-dies_ok {
- $obj = OneOfEach->new( %params,
- content => [ @facts{qw/FactOne FactOne/} ]
- );
-} "dies: new() takes 1 of each, given 2 of one kind";
+isnt exception {
+ $obj = OneOfEach->new( %params, content => [ @facts{qw/FactOne FactOne/} ] );
+}, undef,
+"dies: new() takes 1 of each, given 2 of one kind";
#--------------------------------------------------------------------------#
# report that takes 1 of each
#--------------------------------------------------------------------------#
-lives_ok {
- $obj = OneSpecificAtLeastThreeTotal->new( %params,
- content => [ @facts{qw/FactOne FactTwo FactTwo/} ]
- );
-} "lives: new() takes 1 specific 3 total, given correctly";
+is exception {
+ $obj =
+ OneSpecificAtLeastThreeTotal->new( %params,
+ content => [ @facts{qw/FactOne FactTwo FactTwo/} ] );
+}, undef,
+"lives: new() takes 1 specific 3 total, given correctly";
@@ -1,96 +1,100 @@
# Copyright (c) 2008 by Ricardo Signes. All rights reserved.
# Licensed under terms of Perl itself (the "License").
# You may not use this file except in compliance with the License.
-# A copy of the License was distributed with this file or you may obtain a
+# A copy of the License was distributed with this file or you may obtain a
# copy of the License from http://dev.perl.org/licenses/
use strict;
use warnings;
use Test::More;
-use Test::Exception;
+use Test::Fatal;
use lib 't/lib';
plan tests => 15;
-require_ok( 'Metabase::Report' );
-require_ok( 'Test::Metabase::StringFact' );
+require_ok('Metabase::Report');
+require_ok('Test::Metabase::StringFact');
#--------------------------------------------------------------------------#
# fixtures
-#--------------------------------------------------------------------------#
+#--------------------------------------------------------------------------#
require ReportSubclasses;
require FactSubclasses;
-my %params = (
- resource => "cpan:///distfile/JOHNDOE/Foo-Bar-1.23.tar.gz",
-);
+my %params = ( resource => "cpan:///distfile/JOHNDOE/Foo-Bar-1.23.tar.gz", );
my %facts = (
- FactOne => FactOne->new( %params, content => "FactOne" ),
- FactTwo => FactTwo->new( %params, content => "FactTwo" ),
+ FactOne => FactOne->new( %params, content => "FactOne" ),
+ FactTwo => FactTwo->new( %params, content => "FactTwo" ),
);
-my ($obj, $err);
+my ( $obj, $err );
#--------------------------------------------------------------------------#
# report that takes 1 fact
#--------------------------------------------------------------------------#
-
-lives_ok {
- $obj = JustOneFact->open( %params )
-} "lives: open() given no facts";
+is exception {
+ $obj = JustOneFact->open(%params);
+}, undef,
+"lives: open() given no facts";
isa_ok( $obj, 'JustOneFact' );
-lives_ok {
- $obj->add( 'FactOne' => 'This is FactOne' );
-} "lives: add( 'Class' => 'foo' )";
+is exception {
+ $obj->add( 'FactOne' => 'This is FactOne' );
+}, undef,
+"lives: add( 'Class' => 'foo' )";
-lives_ok {
+is exception {
$obj->close;
-} "lives: close()";
+}, undef,
+"lives: close()";
#--------------------------------------------------------------------------#
# add takes a fact directly
#--------------------------------------------------------------------------#
-lives_ok {
- $obj = JustOneFact->open( %params )
-} "lives: open() given no facts";
+is exception {
+ $obj = JustOneFact->open(%params);
+}, undef,
+"lives: open() given no facts";
isa_ok( $obj, 'JustOneFact' );
+is exception {
+ $obj->add( $facts{FactOne} );
+}, undef,
+"lives: add( \$fact )";
-lives_ok {
- $obj->add( $facts{FactOne} );
-} "lives: add( \$fact )";
-
-lives_ok {
+is exception {
$obj->close;
-} "lives: close()";
+}, undef,
+"lives: close()";
#--------------------------------------------------------------------------#
# errors
#--------------------------------------------------------------------------#
-lives_ok {
- $obj = JustOneFact->open( %params )
-} "lives: open() given no facts";
+is exception {
+ $obj = JustOneFact->open(%params);
+}, undef,
+"lives: open() given no facts";
isa_ok( $obj, 'JustOneFact' );
-lives_ok {
- $obj->add( 'FactOne' => 'This is FactOne' );
-} "lives: add( 'Class' => 'foo' )";
-
-lives_ok {
- $obj->add( 'FactTwo' => 'This is FactTwo' );
-} "lives: add( 'Class2' => 'foo' )";
+is exception {
+ $obj->add( 'FactOne' => 'This is FactOne' );
+}, undef,
+"lives: add( 'Class' => 'foo' )";
-eval { $obj->close };
-like( $@, qr/content invalid/, "dies: close() with two facts") ;
+is exception {
+ $obj->add( 'FactTwo' => 'This is FactTwo' );
+}, undef,
+"lives: add( 'Class2' => 'foo' )";
+$err = exception { $obj->close };
+like $err, qr/content invalid/, "dies: close() with two facts";
@@ -1,50 +1,49 @@
# Copyright (c) 2010 by David Golden. All rights reserved.
# Licensed under terms of Perl itself (the "License").
# You may not use this file except in compliance with the License.
-# A copy of the License was distributed with this file or you may obtain a
+# A copy of the License was distributed with this file or you may obtain a
# copy of the License from http://dev.perl.org/licenses/
use strict;
use warnings;
use Test::More;
-use Test::Exception;
+use Test::Fatal;
use lib 't/lib';
plan tests => 14;
-require_ok( 'Metabase::Resource' );
-require_ok( 'Metabase::Resource::metabase' );
+require_ok('Metabase::Resource');
+require_ok('Metabase::Resource::metabase');
#--------------------------------------------------------------------------#
# fixtures
-#--------------------------------------------------------------------------#
+#--------------------------------------------------------------------------#
-my ($obj, $err);
+my ( $obj, $err );
#--------------------------------------------------------------------------#
# required parameters missing
#--------------------------------------------------------------------------#
-eval { $obj = Metabase::Resource->new() };
-$err = $@;
-like( $err, qr/no resource string provided/, "new() without string throws error" );
+$err = exception { $obj = Metabase::Resource->new() };
+like $err, qr/no resource string provided/, "new() without string throws error";
#--------------------------------------------------------------------------#
# fake an object and test methods
#--------------------------------------------------------------------------#
# unimplemented
-for my $m ( qw/validate/ ) {
+for my $m (qw/validate/) {
my $obj = bless {} => 'Metabase::Resource';
- eval { $obj->$m };
- like( $@, qr/$m not implemented by Metabase::Resource/, "$m not implemented");
+ $err = exception { $obj->$m };
+ like $err, qr/$m not implemented by Metabase::Resource/, "$m not implemented";
}
# bad schema
-eval { $obj = Metabase::Resource->new("noschema") };
-like( $@, qr/could not determine URI scheme from/, "no schema found" );
+$err = exception { $obj = Metabase::Resource->new("noschema") };
+like $err, qr/could not determine URI scheme from/, "no schema found";
#--------------------------------------------------------------------------#
# new should create proper subtype object
@@ -52,14 +51,14 @@ like( $@, qr/could not determine URI scheme from/, "no schema found" );
my $string = "metabase:user:b66c7662-1d34-11de-a668-0df08d1878c0";
-lives_ok{ $obj = Metabase::Resource->new( $string ) }
- "Metabase::Resource->new(\$string) should not die";
+is exception { $obj = Metabase::Resource->new($string) }, undef,
+"Metabase::Resource->new(\$string) should not die";
-isa_ok( $obj, 'Metabase::Resource::metabase' );
-isa_ok( $obj, 'Metabase::Resource::metabase::user' );
+isa_ok( $obj, 'Metabase::Resource::metabase' );
+isa_ok( $obj, 'Metabase::Resource::metabase::user' );
is( $obj->resource, $string, "\$obj->resource correct" );
-is( "$obj", $string, "string overloading working correctly" );
+is( "$obj", $string, "string overloading working correctly" );
#--------------------------------------------------------------------------#
# generates typed metadata
@@ -68,23 +67,23 @@ is( "$obj", $string, "string overloading working correctly" );
# test metadata
my $metadata_types = {
- type => '//str',
- guid => '//str',
+ type => '//str',
+ guid => '//str',
};
my $expected_metadata = {
- type => 'Metabase-Resource-metabase-user',
- guid => 'b66c7662-1d34-11de-a668-0df08d1878c0',
+ type => 'Metabase-Resource-metabase-user',
+ guid => 'b66c7662-1d34-11de-a668-0df08d1878c0',
};
-is_deeply( $metadata_types, $obj->metadata_types, "Metadata types" );
-is_deeply( $expected_metadata, $obj->metadata, "Metadata" );
+is_deeply( $metadata_types, $obj->metadata_types, "Metadata types" );
+is_deeply( $expected_metadata, $obj->metadata, "Metadata" );
#--------------------------------------------------------------------------#
# accessors
#--------------------------------------------------------------------------#
for my $k ( sort keys %$expected_metadata ) {
- is($obj->$k, $expected_metadata->{$k}, "\$obj->$k");
+ is( $obj->$k, $expected_metadata->{$k}, "\$obj->$k" );
}
@@ -1,34 +1,33 @@
# Copyright (c) 2010 by David Golden. All rights reserved.
# Licensed under terms of Perl itself (the "License").
# You may not use this file except in compliance with the License.
-# A copy of the License was distributed with this file or you may obtain a
+# A copy of the License was distributed with this file or you may obtain a
# copy of the License from http://dev.perl.org/licenses/
use strict;
use warnings;
use Test::More;
-use Test::Exception;
+use Test::Fatal;
use lib 't/lib';
plan tests => 7;
-require_ok( 'Metabase::Resource' );
+require_ok('Metabase::Resource');
#--------------------------------------------------------------------------#
# fixtures
-#--------------------------------------------------------------------------#
+#--------------------------------------------------------------------------#
-my ($obj, $err);
+my ( $obj, $err );
#--------------------------------------------------------------------------#
# required parameters missing
#--------------------------------------------------------------------------#
-eval { $obj = Metabase::Resource->new() };
-$err = $@;
-like( $err, qr/no resource string provided/, "new() without string throws error" );
+$err = exception { $obj = Metabase::Resource->new() };
+like $err, qr/no resource string provided/, "new() without string throws error";
#--------------------------------------------------------------------------#
# new should create proper subtype object
@@ -36,10 +35,10 @@ like( $err, qr/no resource string provided/, "new() without string throws error"
my $string = "cpan:///distfile/JOHNDOE/Foo-Bar-1.23.tar.gz";
-lives_ok{ $obj = Metabase::Resource->new( $string ) }
- "Metabase::Resource->new(\$string) should not die";
+is exception { $obj = Metabase::Resource->new($string) }, undef,
+"Metabase::Resource->new(\$string) should not die";
-isa_ok( $obj, 'Metabase::Resource::cpan' );
+isa_ok( $obj, 'Metabase::Resource::cpan' );
is( $obj->resource, $string, "object content correct" );
@@ -50,20 +49,20 @@ is( $obj->resource, $string, "object content correct" );
# test metadata
my $metadata_types = {
- type => '//str',
- cpan_id => '//str',
- dist_file => '//str',
- dist_name => '//str',
- dist_version => '//str',
+ type => '//str',
+ cpan_id => '//str',
+ dist_file => '//str',
+ dist_name => '//str',
+ dist_version => '//str',
};
my $expected_metadata = {
- type => 'Metabase-Resource-cpan-distfile',
- cpan_id => 'JOHNDOE',
- dist_file => 'JOHNDOE/Foo-Bar-1.23.tar.gz',
- dist_name => 'Foo-Bar',
- dist_version => '1.23',
+ type => 'Metabase-Resource-cpan-distfile',
+ cpan_id => 'JOHNDOE',
+ dist_file => 'JOHNDOE/Foo-Bar-1.23.tar.gz',
+ dist_name => 'Foo-Bar',
+ dist_version => '1.23',
};
-is_deeply( $metadata_types, $obj->metadata_types, "Metadata types" );
-is_deeply( $expected_metadata, $obj->metadata, "Metadata" );
+is_deeply( $metadata_types, $obj->metadata_types, "Metadata types" );
+is_deeply( $expected_metadata, $obj->metadata, "Metadata" );
@@ -1,46 +1,45 @@
# Copyright (c) 2010 by David Golden. All rights reserved.
# Licensed under terms of Perl itself (the "License").
# You may not use this file except in compliance with the License.
-# A copy of the License was distributed with this file or you may obtain a
+# A copy of the License was distributed with this file or you may obtain a
# copy of the License from http://dev.perl.org/licenses/
use strict;
use warnings;
use Test::More;
-use Test::Exception;
+use Test::Fatal;
use lib 't/lib';
plan tests => 10;
-require_ok( 'Metabase::Resource' );
+require_ok('Metabase::Resource');
#--------------------------------------------------------------------------#
# fixtures
-#--------------------------------------------------------------------------#
+#--------------------------------------------------------------------------#
-my ($obj, $err);
+my ( $obj, $err );
#--------------------------------------------------------------------------#
# required parameters missing
#--------------------------------------------------------------------------#
-eval { $obj = Metabase::Resource->new() };
-$err = $@;
-like( $err, qr/no resource string provided/, "new() without string throws error" );
+like( exception { $obj = Metabase::Resource->new() },
+qr/no resource string provided/, "new() without string throws error" );
#--------------------------------------------------------------------------#
# new should create proper subtype object
#--------------------------------------------------------------------------#
-my $sha1 = "8c57606294f48eb065dff03f7ffefc1e4e2cdce4";
+my $sha1 = "8c57606294f48eb065dff03f7ffefc1e4e2cdce4";
my $string = "perl:///commit/$sha1";
-lives_ok{ $obj = Metabase::Resource->new( $string ) }
- "Metabase::Resource->new(\$string) should not die";
+is exception { $obj = Metabase::Resource->new($string) }, undef,
+"Metabase::Resource->new(\$string) should not die";
-isa_ok( $obj, 'Metabase::Resource::perl' );
+isa_ok( $obj, 'Metabase::Resource::perl' );
is( $obj->resource, $string, "object content correct" );
@@ -51,22 +50,22 @@ is( $obj->resource, $string, "object content correct" );
# test metadata
my $metadata_types = {
- type => '//str',
- sha1 => '//str',
+ type => '//str',
+ sha1 => '//str',
};
my $expected_metadata = {
- type => 'Metabase-Resource-perl-commit',
- sha1 => $sha1,
+ type => 'Metabase-Resource-perl-commit',
+ sha1 => $sha1,
};
-is_deeply( $metadata_types, $obj->metadata_types, "Metadata types" );
-is_deeply( $expected_metadata, $obj->metadata, "Metadata" );
+is_deeply( $metadata_types, $obj->metadata_types, "Metadata types" );
+is_deeply( $expected_metadata, $obj->metadata, "Metadata" );
is( $obj->sha1, $sha1, "sha1() correct" );
-is( $obj->full_url, "http://perl5.git.perl.org/perl.git/$sha1",
- "full_url()",
-);
-is( $obj->full_url('example.com'), "http://example.com/perl.git/$sha1",
- "full_url('example.com')"
+is( $obj->full_url, "http://perl5.git.perl.org/perl.git/$sha1", "full_url()", );
+is(
+ $obj->full_url('example.com'),
+ "http://example.com/perl.git/$sha1",
+ "full_url('example.com')"
);
@@ -2,7 +2,7 @@ use strict;
use warnings;
use Test::More;
-use Test::Exception;
+use Test::Fatal;
use File::Spec;
use File::Temp 0.20;
use Cwd;
@@ -15,26 +15,29 @@ use JSON 2 ();
my $json = JSON->new->ascii;
sub _compare {
- my ($report1, $report2) = @_;
- is( $report1->core_metadata->{resource},
- $report2->core_metadata->{resource},
- "Checking URI");
- is ( $report1->guid, $report2->guid, "Checking GUID" );
- for my $i ( 0 .. 1 ) {
- is_deeply( $report1->{content}[$i]->as_struct,
- $report2->{content}[$i]->as_struct,
- "Checking fact $i",
+ my ( $report1, $report2 ) = @_;
+ is(
+ $report1->core_metadata->{resource},
+ $report2->core_metadata->{resource},
+ "Checking URI"
);
- }
- return 1;
+ is( $report1->guid, $report2->guid, "Checking GUID" );
+ for my $i ( 0 .. 1 ) {
+ is_deeply(
+ $report1->{content}[$i]->as_struct,
+ $report2->{content}[$i]->as_struct,
+ "Checking fact $i",
+ );
+ }
+ return 1;
}
#--------------------------------------------------------------------------#
# start testing
#--------------------------------------------------------------------------#
-require_ok( 'Metabase::User::Profile' );
-require_ok( 'Metabase::User::Secret' );
+require_ok('Metabase::User::Profile');
+require_ok('Metabase::User::Secret');
#--------------------------------------------------------------------------#
# new profile creation
@@ -42,14 +45,15 @@ require_ok( 'Metabase::User::Secret' );
my $profile;
-lives_ok {
- $profile = Metabase::User::Profile->create(
- full_name => "J\x{022f}hn Doe",
- email_address => 'jdoe@example.com',
- );
-} "create new profile";
+is exception {
+ $profile = Metabase::User::Profile->create(
+ full_name => "J\x{022f}hn Doe",
+ email_address => 'jdoe@example.com',
+ );
+}, undef,
+"create new profile";
-isa_ok($profile, 'Metabase::User::Profile');
+isa_ok( $profile, 'Metabase::User::Profile' );
#--------------------------------------------------------------------------#
# save and load profiles
@@ -59,21 +63,21 @@ my $tempdir = File::Temp::tempdir( CLEANUP => 1 );
my $profile_file = File::Spec->catfile( $tempdir, 'profile.json' );
-$profile->save( $profile_file );
+$profile->save($profile_file);
ok( -r $profile_file, 'profile saved to file' );
-my $profile_copy = Metabase::User::Profile->load( $profile_file );
+my $profile_copy = Metabase::User::Profile->load($profile_file);
ok( $profile_copy, "Loaded profile file (created with ->create)" );
-isa_ok($profile_copy, 'Metabase::User::Profile');
+isa_ok( $profile_copy, 'Metabase::User::Profile' );
_compare( $profile, $profile_copy );
-
# try profile-generator
-my $bin = File::Spec->rel2abs(File::Spec->catfile( qw/bin metabase-profile/ ));
+my $bin = File::Spec->rel2abs( File::Spec->catfile(qw/bin metabase-profile/) );
my $cwd = Cwd::cwd();
-chdir $tempdir; END { chdir $cwd }
+chdir $tempdir;
+END { chdir $cwd }
my $output_file = 'my.profile.json';
my $X = $^X =~ m/\s/ ? qq{"$^X"} : $^X;
$bin = $bin =~ m/\s/ ? qq{"$bin"} : $bin;
@@ -83,8 +87,8 @@ ok( -r $output_file, 'created named profile file with metabase-profile' );
qx/$X $bin --name "JohnPublic" --email jp\@example.com --secret 3.14159/;
ok( -r 'metabase_id.json', 'created default profile file with metabase-profile' );
-my $file_guts = do { local (@ARGV,$/) = 'metabase_id.json'; <> };
-my $facts = $json->decode($file_guts);
+my $file_guts = do { local ( @ARGV, $/ ) = 'metabase_id.json'; <> };
+my $facts = $json->decode($file_guts);
my $profile_copy2 = Metabase::User::Profile->from_struct( $facts->[0] );
ok( $profile_copy2, "Loaded profile from file" );
my $secret_copy2 = Metabase::User::Secret->from_struct( $facts->[1] );
@@ -0,0 +1,5 @@
+; Install Code::TidyAll
+; run "tidyall -a" to tidy all files
+; run "tidyall -g" to tidy only files modified from git
+[PerlTidy]
+select = {lib,t}/**/*.{pl,pm,t}
@@ -0,0 +1,95 @@
+use 5.006;
+use strict;
+use warnings;
+
+# this test was generated with Dist::Zilla::Plugin::Test::Compile 2.039
+
+use Test::More tests => 17 + ($ENV{AUTHOR_TESTING} ? 1 : 0);
+
+
+
+my @module_files = (
+ 'Metabase/Fact.pm',
+ 'Metabase/Fact/Hash.pm',
+ 'Metabase/Fact/String.pm',
+ 'Metabase/Report.pm',
+ 'Metabase/Resource.pm',
+ 'Metabase/Resource/cpan.pm',
+ 'Metabase/Resource/cpan/distfile.pm',
+ 'Metabase/Resource/metabase.pm',
+ 'Metabase/Resource/metabase/fact.pm',
+ 'Metabase/Resource/metabase/user.pm',
+ 'Metabase/Resource/perl.pm',
+ 'Metabase/Resource/perl/commit.pm',
+ 'Metabase/User/EmailAddress.pm',
+ 'Metabase/User/FullName.pm',
+ 'Metabase/User/Profile.pm',
+ 'Metabase/User/Secret.pm'
+);
+
+my @scripts = (
+ 'bin/metabase-profile'
+);
+
+# fake home for cpan-testers
+use File::Temp;
+local $ENV{HOME} = File::Temp::tempdir( CLEANUP => 1 );
+
+
+my $inc_switch = -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<perlfaq8/How can I capture STDERR from an external command?>
+ my $stderr = IO::Handle->new;
+
+ my $pid = open3($stdin, '>&STDERR', $stderr, $^X, $inc_switch, '-e', "require q[$lib]");
+ binmode $stderr, ':crlf' if $^O eq 'MSWin32';
+ my @_warnings = <$stderr>;
+ waitpid($pid, 0);
+ is($?, 0, "$lib loaded ok");
+
+ if (@_warnings)
+ {
+ warn @_warnings;
+ push @warnings, @_warnings;
+ }
+}
+
+foreach my $file (@scripts)
+{ SKIP: {
+ open my $fh, '<', $file or warn("Unable to open $file: $!"), next;
+ my $line = <$fh>;
+ close $fh and skip("$file isn't perl", 1) unless $line =~ /^#!.*?\bperl\b\s*(.*)$/;
+
+ my @flags = $1 ? split(/\s+/, $1) : ();
+
+ my $stderr = IO::Handle->new;
+
+ my $pid = open3($stdin, '>&STDERR', $stderr, $^X, $inc_switch, @flags, '-c', $file);
+ binmode $stderr, ':crlf' if $^O eq 'MSWin32';
+ my @_warnings = <$stderr>;
+ waitpid($pid, 0);
+ is($?, 0, "$file compiled ok");
+
+ # in older perls, -c output is simply the file portion of the path being tested
+ if (@_warnings = grep { !/\bsyntax OK$/ }
+ grep { chomp; $_ ne (File::Spec->splitpath($file))[2] } @_warnings)
+ {
+ warn @_warnings;
+ push @warnings, @_warnings;
+ }
+} }
+
+
+
+is(scalar(@warnings), 0, 'no warnings found') if $ENV{AUTHOR_TESTING};
+
+
@@ -1,35 +1,52 @@
-#!perl
-# This test is generated by Dist::Zilla::Plugin::Test::PodSpelling
-
+use strict;
+use warnings;
use Test::More;
-eval "use Pod::Wordlist::hanekomu";
-plan skip_all => "Pod::Wordlist::hanekomu required for testing POD spelling"
- if $@;
-
-eval "use Test::Spelling 0.12";
-plan skip_all => "Test::Spelling 0.12 required for testing POD spelling"
- if $@;
+# generated by Dist::Zilla::Plugin::Test::PodSpelling 2.006002
+use Test::Spelling 0.12;
+use Pod::Wordlist;
add_stopwords(<DATA>);
-all_pod_files_spelling_ok('bin', 'lib');
+all_pod_files_spelling_ok( qw( bin lib ) );
__DATA__
-GUID
-IDentifier
-JSON
-URI's
-UTC
-analyses
-cpan
-datatype
-distfile
-guid
-metabase
David
Golden
+dagolden
Ricardo
Signes
+rjbs
Merijn
Brand
-
+hmbrand
+Steinbrunner
+dsteinbrunner
+Karen
+Etheridge
+ether
+Nathan
+Gary
+Glenn
+nglenn
+Randy
+Stauner
+rwstauner
+lib
+Metabase
+User
+Profile
+FullName
+Fact
+Resource
+metabase
+user
+Secret
+cpan
+fact
+Report
+perl
+commit
+String
+distfile
+Hash
+EmailAddress
@@ -1,7 +1,6 @@
#!perl
+# This file was automatically generated by Dist::Zilla::Plugin::MetaTests.
-use Test::More;
+use Test::CPAN::Meta;
-eval "use Test::CPAN::Meta";
-plan skip_all => "Test::CPAN::Meta required for testing META.yml" if $@;
meta_yaml_ok();
@@ -0,0 +1,8 @@
+#!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} );
@@ -1,13 +1,7 @@
#!perl
+# This file was automatically generated by Dist::Zilla::Plugin::PodCoverageTests.
-use Test::More;
-
-eval "use Test::Pod::Coverage 1.08";
-plan skip_all => "Test::Pod::Coverage 1.08 required for testing POD coverage"
- if $@;
-
-eval "use Pod::Coverage::TrustPod";
-plan skip_all => "Pod::Coverage::TrustPod required for testing POD coverage"
- if $@;
+use Test::Pod::Coverage 1.08;
+use Pod::Coverage::TrustPod;
all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' });
@@ -1,7 +1,6 @@
#!perl
+# This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests.
use Test::More;
-
-eval "use Test::Pod 1.41";
-plan skip_all => "Test::Pod 1.41 required for testing POD" if $@;
+use Test::Pod 1.41;
all_pod_files_ok();
@@ -1,8 +1,12 @@
#!perl
+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();
@@ -1,12 +1,22 @@
-#!/usr/bin/perl
-use 5.006;
use strict;
use warnings;
use Test::More;
-use Test::Requires {
- 'Test::Version' => 0.04,
+# generated by Dist::Zilla::Plugin::Test::Version 0.002004
+BEGIN { eval "use Test::Version; 1;" or die $@; }
+
+my @imports = ( 'version_all_ok' );
+
+my $params = {
+ is_strict => 0,
+ has_version => 1,
};
+push @imports, $params
+ if version->parse( $Test::Version::VERSION ) >= version->parse('1.002');
+
+
+Test::Version->import(@imports);
+
version_all_ok;
done_testing;