From: Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
Date: Thu, 19 Mar 2015 15:09:17 +0000 (+0100)
Subject: Port ::Admin from Moose to Moo
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class.git;a=commitdiff_plain;h=751a68cca30c1f4f5043e692d57c9fc454686350

Port ::Admin from Moose to Moo
---

diff --git a/lib/DBIx/Class/Admin.pm b/lib/DBIx/Class/Admin.pm
index 65c703d..5a20472 100644
--- a/lib/DBIx/Class/Admin.pm
+++ b/lib/DBIx/Class/Admin.pm
@@ -11,14 +11,11 @@ BEGIN {
   }
 }
 
-use JSON::Any qw(DWIW PP JSON CPANEL XS);
-use Moose;
-use MooseX::Types::Moose qw/Int Str Any Bool/;
-use DBIx::Class::Admin::Types qw/DBICConnectInfo DBICHashRef/;
-use MooseX::Types::JSON qw(JSON);
-use MooseX::Types::Path::Class qw(Dir File);
-use MooseX::Types::LoadableClass qw(LoadableClass);
+use Moo;
 use Try::Tiny;
+use Module::Runtime ();
+use Sub::Quote 'quote_sub';
+use DBIx::Class::_Types qw(File Dir Str Bool DBICConnectInfo DBICHashRef DBICSchemaClass DBICSchema);
 use namespace::clean;
 
 =head1 NAME
@@ -72,11 +69,10 @@ the class of the schema to load
 =cut
 
 has 'schema_class' => (
-  is  => 'ro',
-  isa => LoadableClass,
+  is => 'ro',
+  isa => DBICSchemaClass,
 );
 
-
 =head2 schema
 
 A pre-connected schema object can be provided for manipulation
@@ -84,9 +80,8 @@ A pre-connected schema object can be provided for manipulation
 =cut
 
 has 'schema' => (
-  is          => 'ro',
-  isa         => 'DBIx::Class::Schema',
-  lazy_build  => 1,
+  is => 'lazy',
+  isa => DBICSchema,
 );
 
 sub _build_schema {
@@ -116,8 +111,7 @@ a hash ref or json string to be used for identifying data to manipulate
 
 has 'where' => (
   is      => 'rw',
-  isa     => DBICHashRef,
-  coerce  => 1,
+  isa     => DBICHashRef(coerce => 1),
 );
 
 
@@ -129,8 +123,7 @@ a hash ref or json string to be used for inserting or updating data
 
 has 'set' => (
   is      => 'rw',
-  isa     => DBICHashRef,
-  coerce  => 1,
+  isa     => DBICHashRef(coerce => 1),
 );
 
 
@@ -142,8 +135,7 @@ a hash ref or json string to be used for passing additional info to the ->search
 
 has 'attrs' => (
   is      => 'rw',
-  isa     => DBICHashRef,
-  coerce  => 1,
+  isa     => DBICHashRef(coerce => 1),
 );
 
 
@@ -155,9 +147,9 @@ connect_info the arguments to provide to the connect call of the schema_class
 
 has 'connect_info' => (
   is          => 'ro',
-  isa         => DBICConnectInfo,
-  lazy_build  => 1,
-  coerce      => 1,
+  isa         => DBICConnectInfo(coerce => 1),
+  lazy        => 1,
+  builder     => 1,
 );
 
 sub _build_connect_info {
@@ -176,8 +168,7 @@ The config file should be in a format readable by Config::Any.
 
 has config_file => (
   is      => 'ro',
-  isa     => File,
-  coerce  => 1,
+  isa     => File(coerce => 1),
 );
 
 
@@ -203,8 +194,9 @@ config_stanza will still be required.
 
 has config => (
   is          => 'ro',
-  isa         => DBICHashRef,
-  lazy_build  => 1,
+  isa         => DBICHashRef(coerce => 1),
+  lazy        => 1,
+  builder     => 1,
 );
 
 sub _build_config {
@@ -229,8 +221,7 @@ The location where sql ddl files should be created or found for an upgrade.
 
 has 'sql_dir' => (
   is      => 'ro',
-  isa     => Dir,
-  coerce  => 1,
+  isa     => Dir(coerce => 1),
 );
 
 
@@ -292,12 +283,6 @@ has quiet => (
   isa => Bool,
 );
 
-has '_confirm' => (
-  is  => 'bare',
-  isa => Bool,
-);
-
-
 =head2 trace
 
 Toggle DBIx::Class debug output
@@ -560,9 +545,6 @@ sub select {
 sub _confirm {
   my ($self) = @_;
 
-  # mainly here for testing
-  return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
-
   print "Are you sure you want to do this? (type YES to confirm) \n";
   my $response = <STDIN>;
 
diff --git a/lib/DBIx/Class/Admin/Types.pm b/lib/DBIx/Class/Admin/Types.pm
deleted file mode 100644
index c6f37c6..0000000
--- a/lib/DBIx/Class/Admin/Types.pm
+++ /dev/null
@@ -1,52 +0,0 @@
-package # hide from PAUSE
-    DBIx::Class::Admin::Types;
-
-# Workaround for https://rt.cpan.org/Public/Bug/Display.html?id=83336
-use warnings;
-use strict;
-
-use MooseX::Types -declare => [qw(
-    DBICConnectInfo
-    DBICArrayRef
-    DBICHashRef
-)];
-use MooseX::Types::Moose qw/Int HashRef ArrayRef Str Any Bool/;
-use MooseX::Types::JSON qw(JSON);
-
-subtype DBICArrayRef,
-    as ArrayRef;
-
-subtype DBICHashRef,
-    as HashRef;
-
-coerce DBICArrayRef,
-  from JSON,
-  via { _json_to_data ($_) };
-
-coerce DBICHashRef,
-  from JSON,
-  via { _json_to_data($_) };
-
-subtype DBICConnectInfo,
-  as ArrayRef;
-
-coerce DBICConnectInfo,
-  from JSON,
-   via { return _json_to_data($_) } ;
-
-coerce DBICConnectInfo,
-  from Str,
-    via { return _json_to_data($_) };
-
-coerce DBICConnectInfo,
-  from HashRef,
-   via { [ $_ ] };
-
-sub _json_to_data {
-  my ($json_str) = @_;
-  my $json = JSON::Any->new(allow_barekey => 1, allow_singlequote => 1, relaxed=>1);
-  my $ret = $json->jsonToObj($json_str);
-  return $ret;
-}
-
-1;
diff --git a/lib/DBIx/Class/Optional/Dependencies.pm b/lib/DBIx/Class/Optional/Dependencies.pm
index 1cc14a9..87254da 100644
--- a/lib/DBIx/Class/Optional/Dependencies.pm
+++ b/lib/DBIx/Class/Optional/Dependencies.pm
@@ -100,11 +100,6 @@ my $dbic_reqs = {
 
   admin => {
     include => '_json_any',
-    req => {
-      %$moose_basic,
-      'MooseX::Types::Path::Class' => '0.05',
-      'MooseX::Types::JSON' => '0.02',
-    },
     pod => {
       title => 'DBIx::Class::Admin',
       desc => 'Modules required for the DBIx::Class administrative library',
diff --git a/lib/DBIx/Class/_Types.pm b/lib/DBIx/Class/_Types.pm
new file mode 100644
index 0000000..e13228f
--- /dev/null
+++ b/lib/DBIx/Class/_Types.pm
@@ -0,0 +1,172 @@
+package # hide from PAUSE
+  DBIx::Class::_Types;
+
+use strict;
+use warnings;
+use Carp qw(confess);
+
+use Path::Class;
+use Sub::Name;
+use Scalar::Util qw(blessed looks_like_number reftype);
+use Class::Load qw(load_optional_class);
+
+sub import {
+  my ($package, @methods) = @_;
+  my $caller = caller;
+  for my $method (@methods) {
+    my $check = $package->can($method) or confess "$package does not export $method";
+    my $coerce = $package->can("coerce_$method");
+    my $full_method = "${caller}::${method}";
+    { no strict;
+      *{$full_method} = subname $full_method => sub {
+        my %args = @_;
+        ($coerce && $args{coerce} && wantarray)
+          ? ( $check, coerce => $coerce )
+          : $check;
+      };
+    }
+  }
+}
+
+sub error {
+  my ($default, $value, %args) = @_;
+  if(my $err = $args{err}) {
+    confess $err->($value);
+  } else {
+    confess $default;
+  }
+}
+
+sub Str {
+  error("Value $_[0] must be a string")
+    unless Defined(@_) && !ref $_[0];
+}
+
+sub Dir {
+  error("Value $_[0] must be a Path::Class::Dir")
+    unless Object(@_) && $_[0]->isa("Path::Class::Dir");
+}
+
+sub coerce_Dir{ dir($_[0]) }
+
+sub File {
+  error("Value $_[0] must be a Path::Class::File")
+    unless Object(@_) && $_[0]->isa("Path::Class::File");
+}
+
+sub coerce_File { file($_[0]) }
+
+sub Defined {
+  error("Value must be Defined", @_)
+    unless defined($_[0]);
+}
+
+sub UnDefined {
+  error("Value must be UnDefined", @_)
+    unless !defined($_[0]);
+}
+
+sub Bool {
+  error("$_[0] is not a valid Boolean", @_)
+    unless(!defined($_[0]) || $_[0] eq "" || "$_[0]" eq '1' || "$_[0]" eq '0');
+}
+
+sub Number {
+  error("weight must be a Number greater than or equal to 0, not $_[0]", @_)
+    unless(Defined(@_) && looks_like_number($_[0]));
+}
+
+sub Integer {
+  error("$_[0] must be an Integer", @_)
+    unless(Number(@_) && (int($_[0]) == $_[0]));
+}
+
+sub HashRef {
+  error("$_[0] must be a HashRef", @_)
+    unless(Defined(@_) && (reftype($_[0]) eq 'HASH'));
+}
+
+sub ArrayRef {
+  error("$_[0] must be an ArrayRef", @_)
+    unless(Defined(@_) && (reftype($_[0]) eq 'ARRAY'));
+}
+
+sub _json_to_data {
+  my ($json_str) = @_;
+  require JSON::Any;
+  JSON::Any->import(qw(DWIW XS JSON));
+  my $json = JSON::Any->new(allow_barekey => 1, allow_singlequote => 1, relaxed=>1);
+  my $ret = $json->jsonToObj($json_str);
+  return $ret;
+}
+
+sub DBICHashRef {
+  HashRef(@_);
+}
+
+sub coerce_DBICHashRef {
+  !ref $_[0] ? _json_to_data(@_)
+    : reftype $_[0] eq 'HASH' ? $_[0]
+    : error("Cannot coerce @{[reftype $_[0]]}")
+  ;
+}
+
+sub DBICConnectInfo {
+  ArrayRef(@_);
+}
+
+sub coerce_DBICConnectInfo {
+  !ref $_[0] ? _json_to_data(@_)
+    : reftype $_[0] eq 'ARRAY' ? $_[0]
+    : reftype $_[0] eq 'HASH'  ? [ $_[0] ]
+    : error("Cannot coerce @{[reftype $_[0]]}")
+  ;
+}
+
+sub PositiveNumber {
+  error("value must be a Number greater than or equal to 0, not $_[0]", @_)
+    unless(Number(@_) && ($_[0] >= 0));
+}
+
+sub PositiveInteger {
+  error("Value must be a Number greater than or equal to 0, not $_[0]", @_)
+    unless(Integer(@_) && ($_[0] >= 0));
+}
+
+sub LoadableClass {
+  error("$_[0] is not a loadable Class", @_)
+    unless(load_optional_class($_[0]));
+}
+
+sub Object {
+  error("Value is not an Object", @_)
+    unless(Defined(@_) && blessed($_[0]));
+}
+
+sub DBICStorageDBI {
+  error("Need an Object of type DBIx::Class::Storage::DBI, not ".ref($_[0]), @_)
+    unless(Object(@_) && ($_[0]->isa('DBIx::Class::Storage::DBI')));
+}
+
+sub DBICStorageDBIReplicatedPool {
+  error("Need an Object of type DBIx::Class::Storage::DBI::Replicated::Pool, not ".ref($_[0]), @_)
+    unless(Object(@_) && ($_[0]->isa('DBIx::Class::Storage::DBI::Replicated::Pool')));
+}
+
+sub DBICSchema {
+  error("Need an Object of type DBIx::Class::Schema, not ".ref($_[0]), @_)
+    unless(Object(@_) && ($_[0]->isa('DBIx::Class::Schema')));
+}
+
+sub DBICSchemaClass {
+  error("Need an Object of type DBIx::Class::Schema, not ".ref($_[0]), @_)
+    unless(LoadableClass(@_) && ($_[0]->isa('DBIx::Class::Schema')));
+}
+
+sub DoesDBICStorageReplicatedBalancer {
+  error("$_[0] does not do DBIx::Class::Storage::DBI::Replicated::Balancer", @_)
+    unless(Object(@_) && $_[0]->does('DBIx::Class::Storage::DBI::Replicated::Balancer') );
+}
+
+1;
+
diff --git a/t/admin/02ddl.t b/t/admin/02ddl.t
index b2414c3..60cdd6d 100644
--- a/t/admin/02ddl.t
+++ b/t/admin/02ddl.t
@@ -13,7 +13,13 @@ use lib qw(t/lib);
 use DBICTest;
 use DBIx::Class::_Util 'sigwarn_silencer';
 
+
 use DBIx::Class::Admin;
+{
+  # no questions
+  no warnings 'redefine';
+  *DBIx::Class::Admin::_confirm = sub { 1 };
+}
 
 # lock early
 DBICTest->init_schema(no_deploy => 1, no_populate => 1);
@@ -96,7 +102,6 @@ clean_dir($ddl_dir);
 my $admin = DBIx::Class::Admin->new(
   schema_class  => 'DBICVersion::Schema',
   sql_dir      => $ddl_dir,
-  _confirm    => 1,
   connect_info  => \@connect_info,
 );
 
diff --git a/t/admin/03data.t b/t/admin/03data.t
index d73f619..9e26332 100644
--- a/t/admin/03data.t
+++ b/t/admin/03data.t
@@ -10,6 +10,11 @@ use lib 't/lib';
 use DBICTest;
 
 use DBIx::Class::Admin;
+{
+  # no questions
+  no warnings 'redefine';
+  *DBIx::Class::Admin::_confirm = sub { 1 };
+}
 
 { # test data maniplulation functions
 
@@ -22,7 +27,6 @@ use DBIx::Class::Admin;
     schema_class=> "DBICTest::Schema",
     connect_info => $schema->storage->connect_info(),
     quiet  => 1,
-    _confirm=>1,
   );
   isa_ok ($admin, 'DBIx::Class::Admin', 'create the admin object');
 
diff --git a/xt/extra/internals/namespaces_cleaned.t b/xt/extra/internals/namespaces_cleaned.t
index 92185ae..565216f 100644
--- a/xt/extra/internals/namespaces_cleaned.t
+++ b/xt/extra/internals/namespaces_cleaned.t
@@ -70,7 +70,6 @@ my $skip_idx = { map { $_ => 1 } (
 
   # not sure how to handle type libraries
   'DBIx::Class::Storage::DBI::Replicated::Types',
-  'DBIx::Class::Admin::Types',
 
   # G::L::D is unclean, but we never inherit from it
   'DBIx::Class::Admin::Descriptive',
@@ -84,6 +83,7 @@ my $skip_idx = { map { $_ => 1 } (
   'DBIx::Class::Optional::Dependencies',
   'DBIx::Class::ResultSource::RowParser::Util',
   'DBIx::Class::_Util',
+  'DBIx::Class::_Types',
 ) };
 
 my $has_moose = eval { require Moose::Util };