From: Christopher H. Laco Date: Sun, 6 May 2007 00:54:31 +0000 (+0000) Subject: RT#22364 (ASH) hopefully fixed with updated prereq X-Git-Tag: v0.01001~1 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3469b2435b72e296830195a12e2b3e1bc5b3cc9d;p=dbsrgits%2FDBIx-Class-UUIDColumns.git RT#22364 (ASH) hopefully fixed with updated prereq Added Data::GUID support Fixed ::Win32API::GUID incorrect subclass Converted to Module::Install Added cargo tests/TEST_AUTHOR Much improved test coverage --- diff --git a/Build.PL b/Build.PL index c17d80e..05e4288 100644 --- a/Build.PL +++ b/Build.PL @@ -1,29 +1,2 @@ -use strict; -use Module::Build; - -my %arguments = ( - create_makefile_pl => 'passthrough', - license => 'perl', - module_name => 'DBIx::Class::UUIDColumns', - requires => { - 'DBIx::Class' => 0.06002, - }, - build_requires => { - 'DBD::SQLite' => 1.11, - 'SQL::Translator' => 0.07 - }, - recommends => { - 'Data::UUID' => 0, - 'APR::UUID' => 0, - 'UUID' => 0, - 'Win32::Guidgen' => 0, - 'Win32API::GUID' => 0, - }, - create_makefile_pl => 'passthrough', - create_readme => 1, - test_files => [ glob('t/*.t')], - add_to_cleanup => ['t/var/*'] -); - -Module::Build->new(%arguments)->create_build_script; - +# $Id: Build.PL 3236 2007-05-05 16:24:35Z claco $ +require 'Makefile.PL'; diff --git a/Changes b/Changes index 631dc44..a303cd3 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,14 @@ Revision history for DBIx::Class::UUIDColumns +0.01001 Sat May 05 20:01:13 2007 + - RT#22364 (ASH) hopefully fixed with updated prereq + - Added Data::GUID support + - Fixed ::Win32API::GUID incorrect subclass + - Converted to Module::Install + - Added cargo tests/TEST_AUTHOR + - Much improved test coverage + - Fixed case where no uuid module found so that it dies with error, not with + method not found + 0.00001 - - initial release \ No newline at end of file + - initial release \ No newline at end of file diff --git a/MANIFEST b/MANIFEST deleted file mode 100644 index 5327ee5..0000000 --- a/MANIFEST +++ /dev/null @@ -1,24 +0,0 @@ -Build.PL -Changes -lib/DBIx/Class/UUIDColumns.pm -lib/DBIx/Class/UUIDColumns/UUIDMaker.pm -lib/DBIx/Class/UUIDColumns/UUIDMaker/APR/UUID.pm -lib/DBIx/Class/UUIDColumns/UUIDMaker/Data/Uniqid.pm -lib/DBIx/Class/UUIDColumns/UUIDMaker/Data/UUID.pm -lib/DBIx/Class/UUIDColumns/UUIDMaker/UUID.pm -lib/DBIx/Class/UUIDColumns/UUIDMaker/Win32/Guidgen.pm -lib/DBIx/Class/UUIDColumns/UUIDMaker/Win32API/GUID.pm -Makefile.PL -MANIFEST This list of files -MANIFEST.SKIP -META.yml -README -t/02pod.t -t/03podcoverage.t -t/04basic.t -t/05uuid.t -t/lib/CustomUUIDMaker.pm -t/lib/UUIDTest.pm -t/lib/UUIDTest/Schema.pm -t/lib/UUIDTest/Schema/Test.pm -t/lib/UUIDTest/Setup.pm diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index 94080e9..1d46b05 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -1,40 +1,17 @@ -# Avoid version control files. -\bRCS\b -\bCVS\b -,v$ -\B\.svn\b - -# Avoid Makemaker generated and utility files. -\bMakefile$ -\bblib -\bMakeMaker-\d -\bpm_to_blib$ -\bblibdirs$ -^MANIFEST\.SKIP$ - -# for developers only :) -^TODO$ - -# Avoid Module::Build generated and utility files. -\bBuild$ -\b_build - -# Avoid temp and backup files. -~$ -\.tmp$ -\.old$ -\.bak$ -\#$ -\b\.# - -# avoid OS X finder files -\.DS_Store$ - -# Don't ship the test db -^t/var - -# Don't ship the last dist we built :) -\.tar\.gz$ - -# Skip maint stuff -^maint/ +\bRCS\b +\bCVS\b +,v$ +\B\.svn\b +t/var +^blib/ +^pm_to_blib +^MakeMaker-\d +Makefile$ +Makefile.old$ +Build.PL +Build.bat +\.db +t/TEST$ +t/SMOKE$ +^blibdirs\.ts +\.gz \ No newline at end of file diff --git a/META.yml b/META.yml deleted file mode 100644 index d5ebfba..0000000 --- a/META.yml +++ /dev/null @@ -1,37 +0,0 @@ ---- -name: DBIx-Class-UUIDColumns -version: 0.01000 -author: - - 'Chia-liang Kao ' -abstract: Implicit uuid columns -license: perl -requires: - DBIx::Class: 0.06002 -recommends: - APR::UUID: 0 - Data::UUID: 0 - UUID: 0 - Win32::Guidgen: 0 - Win32API::GUID: 0 -build_requires: - DBD::SQLite: 1.11 - SQL::Translator: 0.07 -provides: - DBIx::Class::UUIDColumns: - file: lib/DBIx/Class/UUIDColumns.pm - version: 0.01000 - DBIx::Class::UUIDColumns::UUIDMaker: - file: lib/DBIx/Class/UUIDColumns/UUIDMaker.pm - DBIx::Class::UUIDColumns::UUIDMaker::APR::UUID: - file: lib/DBIx/Class/UUIDColumns/UUIDMaker/APR/UUID.pm - DBIx::Class::UUIDColumns::UUIDMaker::Data::UUID: - file: lib/DBIx/Class/UUIDColumns/UUIDMaker/Data/UUID.pm - DBIx::Class::UUIDColumns::UUIDMaker::Data::Uniqid: - file: lib/DBIx/Class/UUIDColumns/UUIDMaker/Data/Uniqid.pm - DBIx::Class::UUIDColumns::UUIDMaker::UUID: - file: lib/DBIx/Class/UUIDColumns/UUIDMaker/UUID.pm - DBIx::Class::UUIDColumns::UUIDMaker::Win32::Guidgen: - file: lib/DBIx/Class/UUIDColumns/UUIDMaker/Win32/Guidgen.pm - DBIx::Class::UUIDColumns::UUIDMaker::Win32API::GUID: - file: lib/DBIx/Class/UUIDColumns/UUIDMaker/Win32API/GUID.pm -generated_by: Module::Build version 0.26 diff --git a/Makefile.PL b/Makefile.PL index 51d31fd..cfc559d 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -1,31 +1,41 @@ -# Note: this file was auto-generated by Module::Build::Compat version 0.03 - - unless (eval "use Module::Build::Compat 0.02; 1" ) { - print "This module requires Module::Build to install itself.\n"; - - require ExtUtils::MakeMaker; - my $yn = ExtUtils::MakeMaker::prompt - (' Install Module::Build now from CPAN?', 'y'); - - unless ($yn =~ /^y/i) { - die " *** Cannot install without Module::Build. Exiting ...\n"; - } - - require Cwd; - require File::Spec; - require CPAN; - - # Save this 'cause CPAN will chdir all over the place. - my $cwd = Cwd::cwd(); - my $makefile = File::Spec->rel2abs($0); - - CPAN::Shell->install('Module::Build::Compat') - or die " *** Cannot install without Module::Build. Exiting ...\n"; - - chdir $cwd or die "Cannot chdir() back to $cwd: $!"; - } - eval "use Module::Build::Compat 0.02; 1" or die $@; - use lib '_build/lib'; - Module::Build::Compat->run_build_pl(args => \@ARGV); - require Module::Build; - Module::Build::Compat->write_makefile(build_class => 'Module::Build'); +# $Id: Makefile.PL 3236 2007-05-05 16:24:35Z claco $ +use strict; +use warnings; +use inc::Module::Install 0.65; + +name 'DBIx-Class-UUIDColumns'; +license 'perl'; +perl_version '5.008001'; +all_from 'lib/DBIx/Class/UUIDColumns.pm'; + +requires 'DBIx::Class' => '0.07005'; + +if ( + !eval 'require Data::UUID' && + !eval 'require ARE::UUID' && + !eval 'require UUID' && + !eval 'require Win32::Guidgen' && + !eval 'require Win32API::GUID' && + !eval 'require Data::Uniqid' + ) { + requires 'Data::UUID'; +}; + +build_requires 'DBD::SQLite' => '1.11'; + +recommends 'Data::UUID'; +recommends 'Data::Uniqid'; +recommends 'APR::UUID'; +recommends 'UUID'; +recommends 'Win32::Guidgen'; +recommends 'Win32API::GUID'; + +tests "t/*.t t/*/*.t"; +clean_files "DBIx-Class-UUIDColumns-* t/var"; + +eval { + system 'pod2text lib/DBIx/Class/UUIDColumns.pm > README'; +}; + +auto_install; +WriteAll; diff --git a/README b/README index e6b6ecd..292a405 100644 --- a/README +++ b/README @@ -1,79 +1,79 @@ -NAME - DBIx::Class::UUIDColumns - Implicit uuid columns - -SYNOPSIS - In your DBIx::Class table class: - - __PACKAGE__->load_components(qw/UUIDColumns ... Core/); - __PACKAGE__->uuid_columns('artist_id'); - - Note: The component needs to be loaded *before* Core. - -DESCRIPTION - This DBIx::Class component resembles the behaviour of Class::DBI::UUID, - to make some columns implicitly created as uuid. - - When loaded, "UUIDColumns" will search for a suitable uuid generation - module from the following list of supported modules: - - Data::UUID - APR::UUID* - UUID - Win32::Guidgen - Win32API::GUID - - If no supporting module can be found, an exception will be thrown. - - *APR::UUID will not be loaded under OpenBSD due to an as yet - unidentified XS issue. - - If you would like to use a specific module, you can set "uuid_class": - - __PACKAGE__->uuid_class('::Data::UUID'); - __PACKAGE__->uuid_class('MyUUIDGenerator'); - -METHODS - get_uuid - Returns a uuid string from the current uuid_maker. - - insert - Inserts a new uuid string into each column in "uuid_columns". - - uuid_columns - Takes a list of columns to be filled with uuids during insert. - - __PACKAGE__->uuid_columns('artist_id'); - - uuid_class - Takes the name of a UUIDMaker subclass to be used for uuid value - generation. This can be a fully qualified class name, or a shortcut name - starting with :: that matches one of the available - DBIx::Class::UUIDColumns::UUIDMaker subclasses: - - __PACKAGE__->uuid_class('CustomUUIDGenerator'); - # loads CustomeUUIDGenerator - - __PACKAGE__->uuid_class('::Data::UUID'); - # loads DBIx::Class::UUIDMaker::Data::UUID; - - Note that "uuid_class" chacks to see that the specified class isa - DBIx::Class::UUIDColumns::UUIDMaker subbclass and throws and exception - if it isn't. - - uuid_maker - Returns the current UUIDMaker instance for the given module. - - my $uuid = __PACKAGE__->uuid_maker->as_string; - -SEE ALSO - DBIx::Class::UUIDColumns::UUIDMaker - -AUTHOR - Chia-liang Kao - -CONTRIBUTERS - Chris Laco - -LICENSE - You may distribute this code under the same terms as Perl itself. - +NAME + DBIx::Class::UUIDColumns - Implicit uuid columns + +SYNOPSIS + In your DBIx::Class table class: + + __PACKAGE__->load_components(qw/UUIDColumns ... Core/); + __PACKAGE__->uuid_columns('artist_id'); + + Note: The component needs to be loaded *before* Core. + +DESCRIPTION + This DBIx::Class component resembles the behaviour of Class::DBI::UUID, + to make some columns implicitly created as uuid. + + When loaded, "UUIDColumns" will search for a suitable uuid generation + module from the following list of supported modules: + + Data::UUID + APR::UUID* + UUID + Win32::Guidgen + Win32API::GUID + + If no supporting module can be found, an exception will be thrown. + + *APR::UUID will not be loaded under OpenBSD due to an as yet + unidentified XS issue. + + If you would like to use a specific module, you can set "uuid_class": + + __PACKAGE__->uuid_class('::Data::UUID'); + __PACKAGE__->uuid_class('MyUUIDGenerator'); + +METHODS + get_uuid + Returns a uuid string from the current uuid_maker. + + insert + Inserts a new uuid string into each column in "uuid_columns". + + uuid_columns + Takes a list of columns to be filled with uuids during insert. + + __PACKAGE__->uuid_columns('artist_id'); + + uuid_class + Takes the name of a UUIDMaker subclass to be used for uuid value + generation. This can be a fully qualified class name, or a shortcut name + starting with :: that matches one of the available + DBIx::Class::UUIDColumns::UUIDMaker subclasses: + + __PACKAGE__->uuid_class('CustomUUIDGenerator'); + # loads CustomeUUIDGenerator + + __PACKAGE__->uuid_class('::Data::UUID'); + # loads DBIx::Class::UUIDMaker::Data::UUID; + + Note that "uuid_class" checks to see that the specified class isa + DBIx::Class::UUIDColumns::UUIDMaker subclass and throws and exception if + it isn't. + + uuid_maker + Returns the current UUIDMaker instance for the given module. + + my $uuid = __PACKAGE__->uuid_maker->as_string; + +SEE ALSO + DBIx::Class::UUIDColumns::UUIDMaker + +AUTHOR + Chia-liang Kao + +CONTRIBUTERS + Chris Laco + +LICENSE + You may distribute this code under the same terms as Perl itself. + diff --git a/lib/DBIx/Class/UUIDColumns.pm b/lib/DBIx/Class/UUIDColumns.pm index b4af9ba..65671e4 100644 --- a/lib/DBIx/Class/UUIDColumns.pm +++ b/lib/DBIx/Class/UUIDColumns.pm @@ -14,7 +14,7 @@ __PACKAGE__->uuid_class( __PACKAGE__->_find_uuid_module ); # i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports # brain damage and presumably various other packaging systems too -$VERSION = '0.01000'; +$VERSION = '0.01001'; sub uuid_columns { my $self = shift; @@ -58,6 +58,8 @@ sub get_uuid { sub _find_uuid_module { if (eval{require Data::UUID}) { return '::Data::UUID'; + } elsif (eval{require Data::GUID}) { + return '::Data::GUID'; } elsif ($^O ne 'openbsd' && eval{require APR::UUID}) { # APR::UUID on openbsd causes some as yet unfound nastiness for XS return '::APR::UUID'; @@ -144,8 +146,8 @@ that matches one of the available L subclas __PACKAGE__->uuid_class('::Data::UUID'); # loads DBIx::Class::UUIDMaker::Data::UUID; -Note that C chacks to see that the specified class isa -L subbclass and throws and exception if it isn't. +Note that C checks to see that the specified class isa +L subclass and throws and exception if it isn't. =head2 uuid_maker diff --git a/lib/DBIx/Class/UUIDColumns/UUIDMaker/Data/GUID.pm b/lib/DBIx/Class/UUIDColumns/UUIDMaker/Data/GUID.pm new file mode 100644 index 0000000..9678d1c --- /dev/null +++ b/lib/DBIx/Class/UUIDColumns/UUIDMaker/Data/GUID.pm @@ -0,0 +1,50 @@ +package DBIx::Class::UUIDColumns::UUIDMaker::Data::GUID; + +use strict; +use warnings; + +use base qw/DBIx::Class::UUIDColumns::UUIDMaker/; +use Data::GUID (); + +sub as_string { + return Data::GUID->new->as_string; +}; + +1; +__END__ + +=head1 NAME + +DBIx::Class::UUIDColumns::UUIDMaker::Data::GUID - Create uuids using Data::GUID + +=head1 SYNOPSIS + + package Artist; + __PACKAGE__->load_components(qw/UUIDColumns Core DB/); + __PACKAGE__->uuid_columns( 'artist_id' ); + __PACKAGE__->uuid_class('::Data::GUID'); + +=head1 DESCRIPTION + +This DBIx::Class::UUIDColumns::UUIDMaker subclass uses Data::GUID to generate +uuid strings in the following format: + + 098f2470-bae0-11cd-b579-08002b30bfeb + +=head1 METHODS + +=head2 as_string + +Returns the new uuid as a string. + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Chris Laco + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. diff --git a/lib/DBIx/Class/UUIDColumns/UUIDMaker/Win32API/GUID.pm b/lib/DBIx/Class/UUIDColumns/UUIDMaker/Win32API/GUID.pm index c6661cd..6edc6f3 100644 --- a/lib/DBIx/Class/UUIDColumns/UUIDMaker/Win32API/GUID.pm +++ b/lib/DBIx/Class/UUIDColumns/UUIDMaker/Win32API/GUID.pm @@ -3,7 +3,7 @@ package DBIx::Class::UUIDColumns::UUIDMaker::Win32API::GUID; use strict; use warnings; -use base qw/DBIx::Class::UUIDMaker/; +use base qw/DBIx::Class::UUIDColumns::UUIDMaker/; use Win32API::GUID (); sub as_string { diff --git a/t/02pod.t b/t/02pod.t deleted file mode 100644 index ddc2905..0000000 --- a/t/02pod.t +++ /dev/null @@ -1,6 +0,0 @@ -use Test::More; - -eval "use Test::Pod 1.14"; -plan skip_all => 'Test::Pod 1.14 required' if $@; - -all_pod_files_ok(); diff --git a/t/03podcoverage.t b/t/03podcoverage.t deleted file mode 100644 index d91be5e..0000000 --- a/t/03podcoverage.t +++ /dev/null @@ -1,7 +0,0 @@ -use Test::More; - -eval "use Test::Pod::Coverage 1.04"; -plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@; -plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; - -all_pod_coverage_ok(); diff --git a/t/04basic.t b/t/04basic.t deleted file mode 100644 index 452f33b..0000000 --- a/t/04basic.t +++ /dev/null @@ -1,15 +0,0 @@ -use strict; -use warnings; -use Test::More; - -BEGIN { - eval "use DBD::SQLite"; - plan $@ - ? ( skip_all => 'needs DBD::SQLite for testing' ) - : ( tests => 2 ); -} - -use lib qw(t/lib); - -use_ok('DBIx::Class::UUIDColumns'); -use_ok('DBIx::Class::UUIDColumns::UUIDMaker'); \ No newline at end of file diff --git a/t/05uuid.t b/t/05uuid.t deleted file mode 100644 index a4e243c..0000000 --- a/t/05uuid.t +++ /dev/null @@ -1,42 +0,0 @@ -use strict; -use warnings; -use Test::More; - -BEGIN { - plan skip_all => 'needs Data::UUID for testing' - unless - eval 'require Data::UUID' || - eval 'require APR::UUID' || - eval 'require UUID' || - eval 'require Win32::Guidgen' || - eval 'require Win32API::GUID'; - - plan skip_all => 'needs SQL::Translator for testing' - unless eval 'require SQL::Translator'; - - plan tests => 3; -} - -use lib qw(t/lib); - -use UUIDTest; -use UUIDTest::Setup; - -my $schema = UUIDTest->schema; -my $row; - - -$row = $schema->resultset('Test')->create({ }); -ok UUIDTest::is_uuid( $row->id ), 'got something that loks like a UUID from Auto'; - -UUIDTest::Schema::Test->uuid_class('CustomUUIDMaker'); -Class::C3->reinitialize(); -$row = $schema->resultset('Test')->create({ }); -ok UUIDTest::is_uuid( $row->id ), 'got something that loks like a UUID from CustomUUIDMaker'; - -UUIDTest::Schema::Test->uuid_class('::Data::UUID'); -Class::C3->reinitialize(); -$row = $schema->resultset('Test')->create({ }); -ok UUIDTest::is_uuid( $row->id ), 'got something that loks like a UUID from Data::UUID'; - -1; diff --git a/t/basic.t b/t/basic.t new file mode 100644 index 0000000..6a3b646 --- /dev/null +++ b/t/basic.t @@ -0,0 +1,12 @@ +#!perl -wT +# $Id: basic.t 3235 2007-05-05 16:23:08Z claco $ +use strict; +use warnings; + +BEGIN { + use lib 't/lib'; + use DBIC::Test tests => 2; + + use_ok('DBIx::Class::UUIDColumns'); + use_ok('DBIx::Class::UUIDColumns::UUIDMaker'); +}; diff --git a/t/lib/BadUUIDMaker.pm b/t/lib/BadUUIDMaker.pm new file mode 100644 index 0000000..580adfd --- /dev/null +++ b/t/lib/BadUUIDMaker.pm @@ -0,0 +1,11 @@ +package BadUUIDMaker; + +use strict; +use warnings; + +sub as_string { + return '12345678-1234-2345-3456-123456789090'; +}; + +1; +__END__ \ No newline at end of file diff --git a/t/lib/CustomUUIDMaker.pm b/t/lib/CustomUUIDMaker.pm index 8d70b53..2cdc37a 100755 --- a/t/lib/CustomUUIDMaker.pm +++ b/t/lib/CustomUUIDMaker.pm @@ -4,10 +4,9 @@ use strict; use warnings; use base qw/DBIx::Class::UUIDColumns::UUIDMaker/; -use Data::UUID (); sub as_string { - return Data::UUID->new->to_string(Data::UUID->new->create); + return '12345678-1234-2345-3456-123456789090'; }; 1; diff --git a/t/lib/DBIC/Test.pm b/t/lib/DBIC/Test.pm new file mode 100644 index 0000000..6f254a3 --- /dev/null +++ b/t/lib/DBIC/Test.pm @@ -0,0 +1,112 @@ +# $Id: Test.pm 3236 2007-05-05 16:24:35Z claco $ +package DBIC::Test; +use strict; +use warnings; + +BEGIN { + # little trick by Ovid to pretend to subclass+exporter Test::More + use base qw/Test::Builder::Module Class::Accessor::Grouped/; + use Test::More; + use File::Spec::Functions qw/catfile catdir/; + + @DBIC::Test::EXPORT = @Test::More::EXPORT; + + __PACKAGE__->mk_group_accessors('inherited', qw/db_dir db_file/); +}; + +__PACKAGE__->db_dir(catdir('t', 'var')); +__PACKAGE__->db_file('test.db'); + +## cribbed and modified from DBICTest in DBIx::Class tests +sub init_schema { + my ($self, %args) = @_; + my $db_dir = $args{'db_dir'} || $self->db_dir; + my $db_file = $args{'db_file'} || $self->db_file; + my $namespace = $args{'namespace'} || 'DBIC::TestSchema'; + my $db = catfile($db_dir, $db_file); + + eval 'use DBD::SQLite'; + if ($@) { + BAIL_OUT('DBD::SQLite not installed'); + + return; + }; + + eval 'use DBIC::Test::Schema'; + if ($@) { + BAIL_OUT("Could not load DBIC::Test::Schema: $@"); + + return; + }; + + unlink($db) if -e $db; + unlink($db . '-journal') if -e $db . '-journal'; + mkdir($db_dir) unless -d $db_dir; + + my $dsn = 'dbi:SQLite:' . $db; + my $schema = DBIC::Test::Schema->compose_namespace($namespace)->connect($dsn); + $schema->storage->on_connect_do([ + 'PRAGMA synchronous = OFF', + 'PRAGMA temp_store = MEMORY' + ]); + + __PACKAGE__->deploy_schema($schema, %args); + __PACKAGE__->populate_schema($schema, %args) unless $args{'no_populate'}; + + return $schema; +}; + +sub deploy_schema { + my ($self, $schema, %options) = @_; + my $eval = $options{'eval_deploy'}; + + eval 'use SQL::Translator'; + if (!$@ && !$options{'no_deploy'}) { + eval { + $schema->deploy(); + }; + if ($@ && !$eval) { + die $@; + }; + } else { + open IN, catfile('t', 'sql', 'test.sqlite.sql'); + my $sql; + { local $/ = undef; $sql = ; } + close IN; + eval { + ($schema->storage->dbh->do($_) || print "Error on SQL: $_\n") for split(/;\n/, $sql); + }; + if ($@ && !$eval) { + die $@; + }; + }; +}; + +sub clear_schema { + my ($self, $schema, %options) = @_; + + foreach my $source ($schema->sources) { + $schema->resultset($source)->delete_all; + }; +}; + +sub populate_schema { + my ($self, $schema, %options) = @_; + + if ($options{'clear'}) { + $self->clear_schema($schema, %options); + }; +}; + +sub is_uuid { + my $value = defined $_[0] ? shift : ''; + + return ($value =~ m/ ^[0-9a-f]{8}- + [0-9a-f]{4}- + [0-9a-f]{4}- + [0-9a-f]{4}- + [0-9a-f]{12}$ + /ix); +}; + +1; diff --git a/t/lib/DBIC/Test/Schema.pm b/t/lib/DBIC/Test/Schema.pm new file mode 100644 index 0000000..94f2362 --- /dev/null +++ b/t/lib/DBIC/Test/Schema.pm @@ -0,0 +1,15 @@ +# $Id: Schema.pm 3236 2007-05-05 16:24:35Z claco $ +package DBIC::Test::Schema; +use strict; +use warnings; + +BEGIN { + use base qw/DBIx::Class::Schema/; +}; +__PACKAGE__->load_classes; + +sub dsn { + return shift->storage->connect_info->[0]; +}; + +1; diff --git a/t/lib/UUIDTest/Schema/Test.pm b/t/lib/DBIC/Test/Schema/Test.pm similarity index 58% rename from t/lib/UUIDTest/Schema/Test.pm rename to t/lib/DBIC/Test/Schema/Test.pm index ab16ca1..798d91c 100644 --- a/t/lib/UUIDTest/Schema/Test.pm +++ b/t/lib/DBIC/Test/Schema/Test.pm @@ -1,17 +1,21 @@ -package # hide from PAUSE - UUIDTest::Schema::Test; - -use base 'DBIx::Class::Core'; - -__PACKAGE__->load_components(qw/UUIDColumns Core/); -__PACKAGE__->table('test'); -__PACKAGE__->add_columns( - 'id' => { - data_type => 'varchar', - size => 36, - }, -); -__PACKAGE__->set_primary_key('id'); -__PACKAGE__->uuid_columns('id'); - -1; +# $Id: Test.pm 3236 2007-05-05 16:24:35Z claco $ +package DBIC::Test::Schema::Test; +use strict; +use warnings; + +BEGIN { + use base qw/DBIx::Class::Core/; +}; + +__PACKAGE__->load_components(qw/UUIDColumns Core/); +__PACKAGE__->table('test'); +__PACKAGE__->add_columns( + 'id' => { + data_type => 'varchar', + size => 36, + }, +); +__PACKAGE__->set_primary_key('id'); +__PACKAGE__->uuid_columns('id'); + +1; diff --git a/t/lib/UUIDTest.pm b/t/lib/UUIDTest.pm deleted file mode 100755 index 5d66484..0000000 --- a/t/lib/UUIDTest.pm +++ /dev/null @@ -1,32 +0,0 @@ -package # hide from PAUSE - UUIDTest; - -use strict; -use warnings; -use UUIDTest::Schema; - -sub initialise { - - my $db_file = "t/var/UUIDTest.db"; - - unlink($db_file) if -e $db_file; - unlink($db_file . "-journal") if -e $db_file . "-journal"; - mkdir("t/var") unless -d "t/var"; - - my $dsn = "dbi:SQLite:${db_file}"; - - return UUIDTest::Schema->compose_connection('UUIDTest' => $dsn); -} - -sub is_uuid { - my $value = defined $_[0] ? shift : ''; - - return ($value =~ m/ ^[0-9a-f]{8}- - [0-9a-f]{4}- - [0-9a-f]{4}- - [0-9a-f]{4}- - [0-9a-f]{12}$ - /ix); -}; - -1; diff --git a/t/lib/UUIDTest/Schema.pm b/t/lib/UUIDTest/Schema.pm deleted file mode 100644 index ab60c7f..0000000 --- a/t/lib/UUIDTest/Schema.pm +++ /dev/null @@ -1,10 +0,0 @@ -package # hide from PAUSE - UUIDTest::Schema; - -use base qw/DBIx::Class::Schema/; - -no warnings qw/qw/; - -__PACKAGE__->load_classes(qw/ Test /); - -1; diff --git a/t/lib/UUIDTest/Setup.pm b/t/lib/UUIDTest/Setup.pm deleted file mode 100755 index a9efc71..0000000 --- a/t/lib/UUIDTest/Setup.pm +++ /dev/null @@ -1,15 +0,0 @@ -use strict; -use warnings; -use UUIDTest; - -my $schema = UUIDTest->initialise; - -$schema->storage->on_connect_do([ "PRAGMA synchronous = OFF" ]); - -my $dbh = $schema->storage->dbh; - -$schema->deploy; - -$schema->storage->dbh->do("PRAGMA synchronous = OFF"); - -1; diff --git a/t/manifest.t b/t/manifest.t new file mode 100644 index 0000000..5a6206f --- /dev/null +++ b/t/manifest.t @@ -0,0 +1,22 @@ +#!perl -wT +# $Id: manifest.t 3236 2007-05-05 16:24:35Z claco $ +use strict; +use warnings; + +BEGIN { + use lib 't/lib'; + use DBIC::Test; + + plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR}; + + eval 'use Test::CheckManifest 0.09'; + if($@) { + plan skip_all => 'Test::CheckManifest 0.09 not installed'; + }; +}; + +ok_manifest({ + exclude => ['/t/var', '/cover_db'], + filter => [qr/\.svn/, qr/cover/, qr/Build(.(PL|bat))?/, qr/_build/], + bool => 'or' +}); diff --git a/t/pod_coverage.t b/t/pod_coverage.t new file mode 100644 index 0000000..c5aad16 --- /dev/null +++ b/t/pod_coverage.t @@ -0,0 +1,23 @@ +#!perl -wT +# $Id: pod_coverage.t 3236 2007-05-05 16:24:35Z claco $ +use strict; +use warnings; + +BEGIN { + use lib 't/lib'; + use DBIC::Test; + + plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR}; + + eval 'use Test::Pod::Coverage 1.04'; + plan skip_all => 'Test::Pod::Coverage 1.04' if $@; + + eval 'use Pod::Coverage 0.14'; + plan skip_all => 'Pod::Coverage 0.14 not installed' if $@; +}; + +my $trustme = { + trustme => [qr/^(g|s)et_component_class$/] +}; + +all_pod_coverage_ok($trustme); diff --git a/t/pod_spelling.t b/t/pod_spelling.t new file mode 100644 index 0000000..ae4f8c4 --- /dev/null +++ b/t/pod_spelling.t @@ -0,0 +1,32 @@ +#!perl -w +# $Id: pod_spelling.t 3235 2007-05-05 16:23:08Z claco $ +use strict; +use warnings; + +BEGIN { + use lib 't/lib'; + use DBIC::Test; + + plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR}; + + eval 'use Test::Spelling 0.11'; + plan skip_all => 'Test::Spelling 0.11 not installed' if $@; +}; + +set_spell_cmd('aspell list'); + +add_stopwords(); + +all_pod_files_spelling_ok(); + +__DATA__ +uuid +uuids +Chia +liang +Kao +Laco +OpenBSD +UUIDMaker +behaviour +isa diff --git a/t/pod_syntax.t b/t/pod_syntax.t new file mode 100644 index 0000000..63c0224 --- /dev/null +++ b/t/pod_syntax.t @@ -0,0 +1,16 @@ +#!perl -wT +# $Id: pod_syntax.t 3236 2007-05-05 16:24:35Z claco $ +use strict; +use warnings; + +BEGIN { + use lib 't/lib'; + use DBIC::Test; + + plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR}; + + eval 'use Test::Pod 1.00'; + plan skip_all => 'Test::Pod 1.00 not installed' if $@; +}; + +all_pod_files_ok(); diff --git a/t/sql/test.sqlite.sql b/t/sql/test.sqlite.sql new file mode 100644 index 0000000..eff88cb --- /dev/null +++ b/t/sql/test.sqlite.sql @@ -0,0 +1,3 @@ +CREATE TABLE test ( + id VARVHAR(36) PRIMARY KEY NOT NULL +); diff --git a/t/strict.t b/t/strict.t new file mode 100644 index 0000000..9524740 --- /dev/null +++ b/t/strict.t @@ -0,0 +1,53 @@ +#!perl -wT +# $Id: strict.t 3236 2007-05-05 16:24:35Z claco $ +use strict; +use warnings; + +BEGIN { + use lib 't/lib'; + use DBIC::Test; + use File::Find; + use File::Basename; + + plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR}; + + eval 'use Test::Strict'; + plan skip_all => 'Test::Strict not installed' if $@; + plan skip_all => 'Need untaint in newer File::Find' if $] <= 5.006; +}; + +## I hope this can go away if Test::Strict or File::Find::Rule +## finally run under -T. Until then, I'm on my own here. ;-) +my @files; +my %trusted = ( + +); + +find({ wanted => \&wanted, + untaint => 1, + untaint_pattern => qr|^([-+@\w./]+)$|, + untaint_skip => 1, + no_chdir => 1 +}, qw(lib t)); + +sub wanted { + my $name = $File::Find::name; + my $file = fileparse($name); + + return if $name =~ /TestApp/; + + if ($name =~ /\.(pm|pl|t)$/i && !exists($trusted{$file})) { + push @files, $name; + }; +}; + +if (scalar @files) { + plan tests => scalar @files; +} else { + plan tests => 1; + fail 'No perl files found for Test::Strict checks!'; +}; + +foreach (@files) { + strict_ok($_); +}; diff --git a/t/style_no_tabs.t b/t/style_no_tabs.t new file mode 100644 index 0000000..406ad00 --- /dev/null +++ b/t/style_no_tabs.t @@ -0,0 +1,16 @@ +#!perl -wT +# $Id: style_no_tabs.t 3236 2007-05-05 16:24:35Z claco $ +use strict; +use warnings; + +BEGIN { + use lib 't/lib'; + use DBIC::Test; + + plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR}; + + eval 'use Test::NoTabs 0.03'; + plan skip_all => 'Test::NoTabs 0.03 not installed' if $@; +}; + +all_perl_files_ok('lib'); diff --git a/t/uuid.t b/t/uuid.t new file mode 100644 index 0000000..e28ad8c --- /dev/null +++ b/t/uuid.t @@ -0,0 +1,106 @@ +#!perl -wT +# $Id: basic.t 3235 2007-05-05 16:23:08Z claco $ +use strict; +use warnings; + +BEGIN { + use lib 't/lib'; + use DBIC::Test tests => 13; +}; + +my $schema = DBIC::Test->init_schema; +my $row; + +$row = $schema->resultset('Test')->create({ }); +ok DBIC::Test::is_uuid( $row->id ), 'got something that looks like a UUID from Auto'; + +DBIC::Test::Schema::Test->uuid_class('CustomUUIDMaker'); +Class::C3->reinitialize(); +$row = $schema->resultset('Test')->create({ }); +ok DBIC::Test::is_uuid( $row->id ), 'got something that looks like a UUID from CustomUUIDMaker'; + +is(DBIx::Class::UUIDColumns::UUIDMaker->as_string, undef); + +SKIP: { + skip 'Data::UUID not installed', 2 unless eval 'require Data::UUID'; + + DBIC::Test::Schema::Test->uuid_class('::Data::UUID'); + Class::C3->reinitialize(); + is(DBIC::Test::Schema::Test->uuid_class, 'DBIx::Class::UUIDColumns::UUIDMaker::Data::UUID'); + $row = $schema->resultset('Test')->create({ }); + ok DBIC::Test::is_uuid( $row->id ), 'got something that looks like a UUID from Data::UUID'; +}; + +SKIP: { + skip 'Data::GUID not installed', 1 unless eval 'require Data::GUID'; + + DBIC::Test::Schema::Test->uuid_class('::Data::GUID'); + Class::C3->reinitialize(); + $row = $schema->resultset('Test')->create({ }); + ok DBIC::Test::is_uuid( $row->id ), 'got something that looks like a UUID from Data::GUID'; +}; + +SKIP: { + skip 'APR::UUID not installed', 1 unless eval 'require APR::UUID and $^O ne \'openbsd\''; + + DBIC::Test::Schema::Test->uuid_class('::APR::UUID'); + Class::C3->reinitialize(); + $row = $schema->resultset('Test')->create({ }); + ok DBIC::Test::is_uuid( $row->id ), 'got something that looks like a UUID from APR::UUID'; +}; + +SKIP: { + skip 'UUID not installed', 1 unless eval 'require UUID'; + + DBIC::Test::Schema::Test->uuid_class('::UUID'); + Class::C3->reinitialize(); + $row = $schema->resultset('Test')->create({ }); + ok DBIC::Test::is_uuid( $row->id ), 'got something that looks like a UUID from UUID'; +}; + +SKIP: { + skip 'Win32::Guidgen not installed', 1 unless eval 'require Win32::Guidgen'; + + DBIC::Test::Schema::Test->uuid_class('::Win32::Guidgen'); + Class::C3->reinitialize(); + $row = $schema->resultset('Test')->create({ }); + ok DBIC::Test::is_uuid( $row->id ), 'got something that looks like a UUID from Win32::Guidgen'; +}; + +SKIP: { + skip 'Win32API::GUID not installed', 1 unless eval 'require Win32API::GUID'; + + DBIC::Test::Schema::Test->uuid_class('::Win32API::GUID'); + Class::C3->reinitialize(); + $row = $schema->resultset('Test')->create({ }); + ok DBIC::Test::is_uuid( $row->id ), 'got something that looks like a UUID from Win32API::GUID'; +}; + +SKIP: { + skip 'Data::Uniqid not installed', 1 unless eval 'require Data::Uniqid'; + + DBIC::Test::Schema::Test->uuid_class('::Data::Uniqid'); + Class::C3->reinitialize(); + $row = $schema->resultset('Test')->create({ }); + ok $row->id, 'got something from Data::Uniqid'; +}; + +eval { + DBIC::Test::Schema::Test->uuid_class('::JunkIDMaker'); +}; +if ($@ && $@ =~ /could not be loaded/i) { + pass; +} else { + fail('uuid_class dies when class can not be loaded'); +}; + +eval { + DBIC::Test::Schema::Test->uuid_class('BadUUIDMaker'); +}; +if ($@ && $@ =~ /is not a UUIDMaker subclass/i) { + pass; +} else { + fail('uuid_class dies when class no isa DBIx::Class::UUIDColumns::UUIDMaker'); +}; + +1; diff --git a/t/warnings.t b/t/warnings.t new file mode 100644 index 0000000..8f0eb31 --- /dev/null +++ b/t/warnings.t @@ -0,0 +1,53 @@ +#!perl -wT +# $Id: warnings.t 3236 2007-05-05 16:24:35Z claco $ +use strict; +use warnings; + +BEGIN { + use lib 't/lib'; + use DBIC::Test; + use File::Find; + use File::Basename; + + plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR}; + + eval 'use Test::Strict 0.05'; + plan skip_all => 'Test::Strict 0.05 not installed' if $@; + plan skip_all => 'Need untaint in newer File::Find' if $] <= 5.006; +}; + +## I hope this can go away if Test::Strict or File::Find::Rule +## finally run under -T. Until then, I'm on my own here. ;-) +my @files; +my %trusted = ( + +); + +find({ wanted => \&wanted, + untaint => 1, + untaint_pattern => qr|^([-+@\w./]+)$|, + untaint_skip => 1, + no_chdir => 1 +}, qw(lib t)); + +sub wanted { + my $name = $File::Find::name; + my $file = fileparse($name); + + return if $name =~ /TestApp/; + + if ($name =~ /\.(pm|pl|t)$/i && !exists($trusted{$file})) { + push @files, $name; + }; +}; + +if (scalar @files) { + plan tests => scalar @files; +} else { + plan tests => 1; + fail 'No perl files found for Test::Strict checks!'; +}; + +foreach (@files) { + warnings_ok($_); +};