From 79751b7a6cd0ea35752819b0cbe2f440df01b8db Mon Sep 17 00:00:00 2001 From: "MORIYA Masaki (Gardejo)" Date: Fri, 31 Jul 2009 02:07:41 +0900 Subject: [PATCH] added author tests; rename internal methods; modified PODs (s/LICENCE/LICENSE/g) --- Changes | 62 +++++++ MANIFEST | 86 +++++---- Makefile.PL | 173 ++++++++++++------ README | 6 +- lib/SimpleLinks.pm | 6 +- lib/SimpleLinks/Schema/Column.pm | 4 +- lib/SimpleLinks/Schema/Mixin/Base.pm | 10 +- lib/SimpleLinks/Schema/Mixin/Category.pm | 165 +++++++++++------ lib/SimpleLinks/Schema/Mixin/Common.pm | 20 +- lib/SimpleLinks/Schema/Mixin/Tag.pm | 48 ++++- lib/SimpleLinks/Schema/Mixin/Taxonomy.pm | 38 ++-- lib/SimpleLinks/Schema/Mixin/Website.pm | 92 ++++++---- lib/SimpleLinks/Schema/Table.pm | 149 +++++++++------ lib/SimpleLinks/Service/Links.pm | 4 +- lib/SimpleLinks/Web.pm | 20 +- lib/SimpleLinks/Web/Controller/Root.pm | 68 +++++-- lib/SimpleLinks/Web/Model/Links.pm | 4 +- lib/SimpleLinks/Web/View/JSON.pm | 65 +++++++ lib/SimpleLinks/Web/View/MT.pm | 92 ++++++++++ lib/SimpleLinks/Web/View/XML.pm | 65 +++++++ lib/SimpleLinks/Web/View/YAML.pm | 66 +++++++ script/simplelinks.cgi | 2 +- script/simplelinks_server.pl | 2 +- t/00_compile.t | 4 - t/00_startup/00_compile.t | 14 +- t/00_startup/10_create_database.t | 1 + t/10_model/00_category/10_edit.t | 79 -------- .../00_category/00_create.t} | 24 +-- .../02_might_have_parent_at_create.t} | 8 +- t/10_service/00_category/10_read.t | 24 +++ t/10_service/00_category/20_update.t | 116 ++++++++++++ t/10_service/00_category/30_delete.t | 24 +++ .../01_tag/00_create.t} | 20 +- .../02_website/00_create.t} | 9 +- t/20_model/00_compile.t | 19 ++ t/{20_controller => 30_controller}/00_index.t | 2 +- t/40_view/00_compile.t | 36 ++++ t/50_feed/00_compile.t | 19 ++ t/60_web_api/00_compile.t | 19 ++ t/70_command/00_compile.t | 19 ++ t/80_batch/00_compile.t | 19 ++ t/90_cleanup/00_unlink_database.t | 6 +- t/lib/SimpleLinks/Test/Cleanup.pm | 42 ++++- t/lib/SimpleLinks/Test/Constant.pm | 43 ++++- xt/no_tabs.t | 18 ++ xt/perlcritic.t | 18 ++ xt/perlcriticrc | 5 + xt/pod.t | 12 ++ xt/pod_coverage.t | 15 ++ xt/synopsis.t | 12 ++ xt/use_all_modules.t | 14 ++ 51 files changed, 1453 insertions(+), 435 deletions(-) create mode 100644 Changes create mode 100644 lib/SimpleLinks/Web/View/JSON.pm create mode 100644 lib/SimpleLinks/Web/View/MT.pm create mode 100644 lib/SimpleLinks/Web/View/XML.pm create mode 100644 lib/SimpleLinks/Web/View/YAML.pm delete mode 100644 t/00_compile.t delete mode 100644 t/10_model/00_category/10_edit.t rename t/{10_model/00_category/00_insert.t => 10_service/00_category/00_create.t} (79%) rename t/{10_model/00_category/02_might_have_parent_at_insert.t => 10_service/00_category/02_might_have_parent_at_create.t} (97%) create mode 100644 t/10_service/00_category/10_read.t create mode 100644 t/10_service/00_category/20_update.t create mode 100644 t/10_service/00_category/30_delete.t rename t/{10_model/01_tag/00_insert.t => 10_service/01_tag/00_create.t} (80%) rename t/{10_model/02_website/00_insert.t => 10_service/02_website/00_create.t} (91%) create mode 100644 t/20_model/00_compile.t rename t/{20_controller => 30_controller}/00_index.t (100%) create mode 100644 t/40_view/00_compile.t create mode 100644 t/50_feed/00_compile.t create mode 100644 t/60_web_api/00_compile.t create mode 100644 t/70_command/00_compile.t create mode 100644 t/80_batch/00_compile.t create mode 100644 xt/no_tabs.t create mode 100644 xt/perlcritic.t create mode 100644 xt/perlcriticrc create mode 100644 xt/pod.t create mode 100644 xt/pod_coverage.t create mode 100644 xt/synopsis.t create mode 100644 xt/use_all_modules.t diff --git a/Changes b/Changes new file mode 100644 index 0000000..abdc8c5 --- /dev/null +++ b/Changes @@ -0,0 +1,62 @@ +This file documents the revision history for Perl application SimpleLinks. + + +VERSION HISTORY +=============== + +3.14_15 : Released on 1974-06-24 +-------------------------------- + +Blah blah blah. + +- The quick brown fox jumps over the lazy dog. +- Pack my box with five dozen liquor jugs. + + +0.00_00 : Released on 1970-01-01 +-------------------------------- + +Initial version. + +### Features + +- En la mondon venis nova sento, tra la mondo iras forta voko. +- Kimi ga yo ha chiyo ni yachiyo ni + sazare ishi no iwao to narite + koke no musu made. +- Auferstanden aus Ruinen und der Zukunf zugewandt. + + +GENERAL INFORMATION +=================== + +Version notation +---------------- + + [V.vv_rr] Released on YYYY-MM-DD + -------------------------------- + +### V : Major version number + +- Added ambitious feature(s) +- Change in API(s) +- ... + +### vv : Minor version number (in major version) + +- Added normal feture(s) +- Improve any function(s) +- ... + +### rr : Revision number (in minor version) +- Fix bug(s) +- Update document(s) +- ... + + +Format +------ + +This `Changes` file was formatted in Markdown. + + $ perl -MText::Markdown -MFile::Slurp -e 'print (Text::Markdown->new->markdown(scalar read_file("Changes")));' diff --git a/MANIFEST b/MANIFEST index 83b5004..66d7137 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,34 +1,45 @@ -Changes -LICENSE -MANIFEST -META.yml -Makefile.PL -README -SimpleLinks.yml +.gitignore +Changes +LICENSE +MANIFEST +MANIFEST.SKIP +META.yml +Makefile.PL +README +SimpleLinks.yml +extlib/Faktro/Class/Factory.pm +extlib/Faktro/Class/Factory/Wrapper.pm +extlib/Faktro/Class/Flyweight.pm +extlib/Faktro/Class/Flyweight/Wrapper.pm +extlib/Faktro/Class/Singleton.pm +extlib/Faktro/Entity/Common/MailAddress.pm extlib/Faktro/Schema/Factory.pm extlib/Faktro/Schema/Factory/Base.pm extlib/Faktro/Schema/Factory/DBI.pm extlib/Faktro/Schema/Factory/SQLite.pm -extlib/local/lib.pm -inc/Module/AutoInstall.pm -inc/Module/Install.pm -inc/Module/Install/AutoInstall.pm -inc/Module/Install/Base.pm -inc/Module/Install/Can.pm -inc/Module/Install/Fetch.pm -inc/Module/Install/Include.pm -inc/Module/Install/Makefile.pm -inc/Module/Install/Metadata.pm -inc/Module/Install/Scripts.pm -inc/Module/Install/TestBase.pm -inc/Module/Install/Win32.pm -inc/Module/Install/WriteAll.pm -inc/Spiffy.pm -inc/Test/Base.pm -inc/Test/Base/Filter.pm -inc/Test/Builder.pm -inc/Test/Builder/Module.pm -inc/Test/More.pm +extlib/Faktro/Types.pm +extlib/local/lib.pm +inc/Module/AutoInstall.pm +inc/Module/Install.pm +inc/Module/Install/AuthorTests.pm +inc/Module/Install/AutoInstall.pm +inc/Module/Install/Base.pm +inc/Module/Install/Can.pm +inc/Module/Install/Fetch.pm +inc/Module/Install/Include.pm +inc/Module/Install/Makefile.pm +inc/Module/Install/Metadata.pm +inc/Module/Install/TestBase.pm +inc/Module/Install/Win32.pm +inc/Module/Install/WriteAll.pm +inc/Module/Load.pm +inc/Spiffy.pm +inc/Test/Base.pm +inc/Test/Base/Filter.pm +inc/Test/Builder.pm +inc/Test/Builder/Module.pm +inc/Test/More.pm +inc/Test/Warn.pm lib/SimpleLinks.pm lib/SimpleLinks/Schema/Column.pm lib/SimpleLinks/Schema/Mixin/Base.pm @@ -43,13 +54,24 @@ lib/SimpleLinks/Web.pm lib/SimpleLinks/Web/Controller/Root.pm lib/SimpleLinks/Web/Model/Links.pm script/simplelinks.cgi -script/simplelinks_server.pl +script/simplelinks_server.pl t/00_startup/00_compile.t t/00_startup/10_create_database.t -t/10_model/00_category/00_insert.t -t/10_model/10_tag/00_insert.t -t/10_model/20_website/00_insert.t +t/10_model/00_category/00_create.t +t/10_model/00_category/02_might_have_parent_at_create.t +t/10_model/00_category/10_read.t +t/10_model/00_category/20_update.t +t/10_model/00_category/30_delete.t +t/10_model/01_tag/00_create.t +t/10_model/02_website/00_create.t t/20_controller/00_index.t t/90_cleanup/00_unlink_database.t t/lib/SimpleLinks/Test/Cleanup.pm -t/lib/SimpleLinks/Test/Constant.pm +t/lib/SimpleLinks/Test/Constant.pm +xt/no_tabs.t +xt/perlcritic.t +xt/perlcriticrc +xt/pod.t +xt/pod_coverage.t +xt/synopsis.t +xt/use_all_modules.t diff --git a/Makefile.PL b/Makefile.PL index 667b683..996c8be 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -1,89 +1,146 @@ +use strict; +use warnings; + use inc::Module::Install; my $application_root_module = 'lib/SimpleLinks.pm'; +# ================================================================ # meta information -name 'SimpleLinks'; -all_from $application_root_module; -abstract_from $application_root_module; -# author_from $application_root_module; -author 'MORIYA Masaki ("Gardejo") '; -version_from $application_root_module; -license_from $application_root_module; -perl_version_from $application_root_module; - +# ================================================================ +name_from $application_root_module; +abstract_from $application_root_module; +all_from $application_root_module; +version_from $application_root_module; +author 'MORIYA Masaki ("Gardejo") '; +license_from $application_root_module; +resources ( + repository => 'git://github.com/gardejo/p5-ark-sample-simplelinks.git', + bugtracker => undef, + homepage => 'http://blog.eorzea.asia/2009/07/post_35.html', +); # use lib 'extlib'; -no_index directory => 'extlib'; no_index directory => 'examples'; +no_index directory => 'extlib'; +# ================================================================ # build dependencies -build_requires 'Module::Load' => '0'; # -> perl 5.009_004 -build_requires 'Module::Install' => '0.91'; # YAML::Tiny problem at Win32 +# ================================================================ +build_requires 'Module::Install' => '0.80'; # YAML::Tiny problem +build_requires 'Module::Load' => '0'; # > perl 5.009_004 +# ================================================================ # general dependencies -requires 'Any::Moose' => '0'; -requires 'Ark' => '0.001000_002'; -# requires 'Carp' => '0'; # -> perl 5 -# requires 'Data::Dumper::Dumper => '0'; # -> perl 5.005; -requires 'Data::Model' => '0'; -# requires 'Data::Model::Mixin::FindOrCreate' => '0'; # -> Data::Model -# requires 'DBD::SQLite' => '0'; # -> Data::Model -# requires 'DBI' => '0'; # -> Data::Model -requires 'DateTime' => '0'; -requires 'DateTime::Format::MySQL' => '0'; -# requires 'FindBin' => '0'; # -> perl 5.003_07 -requires 'FindBin::libs' => '0'; -requires 'List::MoreUtils' => '0'; # -> Ark -> Data::Util ??? -requires 'List::Util' => '0'; # -> Ark -> Data::Util ??? -# requires 'Scalar::Util' => '0'; # -> Ark -requires 'Text::MicroTemplate::Extended' => '0.01001'; -requires 'URI' => '0'; -requires 'local::lib' => '0'; - +# ================================================================ +perl_version_from $application_root_module; +# requires 'Any::Moose' => '0'; # > Ark > HTTP::Engine + requires 'Ark' => '0.001000_002'; # from GitHub +# requires 'Carp' => '0'; # > perl 5 +# requires 'Data::Dumper' => '0'; # > perl 5.005; + requires 'Data::Model' => '0.00003'; +# requires 'Data::Model::Mixin::FindOrCreate' => '0'; # > Data::Model +# requires 'DBD::SQLite' => '0'; # > Data::Model +# requires 'DBI' => '0'; # > Data::Model +# requires 'DateTime' => '0'; # > HTTP::Engine::Middleware +# requires 'Encode' => '1.9801'; # > perl 5.008_001 + requires 'DateTime::Format::MySQL' => '0'; +# requires 'FindBin' => '0'; # > perl 5.003_07 +# requires 'FindBin::libs' => '0'; # > Ark +# requires 'Getopt::Long' => '0'; # > Ark +# requires 'HTTP::Engine' => '0'; # > Ark +# requires 'HTTP::Engine::Middleware' => '0'; # > Ark + requires 'List::MoreUtils' => '0.24'; # > 'none' fix, HTML::Shakan +# requires 'List::Util' => '0'; # > perl 5.06_00 +# requires 'Mouse' => '0'; # > Ark +# requires 'MouseX::Types' => '0'; # > Ark > HTTP::Engine +# requires 'Scalar::Util' => '1.19'; # > Ark > HTTP::Engine + requires 'Text::MicroTemplate::Extended' => '0.01001'; +# requires 'URI' => '0'; # > Ark + requires 'local::lib' => '0'; + +# Note: I want replace code with Scalar::Util as with Data::Util +# because it interest me in is_number() as alternate looks_like_number(). + +# ================================================================ # optional dependencies +# ================================================================ feacures( - 'Support Markdown format for comment' => [ - -default => 1, - recommends( 'Text::Markdown' => '0' ), - ], 'Support E-mail sending' => [ - -default => 1, - recommends( 'Email::Send' => '0' ), - ], - 'Support YAML format for dump' => [ - -default => 1, - recommends( 'YAML::Any' => '0' ), - # recommends( 'YAML::Syck' => '0' ), + -default => 0, + recommends( 'Email::Send' => '0' ), ], 'Support JSON format for dump' => [ - -default => 1, - recommends( 'JSON::Any' => '0' ), - # recommends( 'JSON::Syck' => '0' ), + -default => 0, + recommends( 'JSON::Any' => '0' ), + ], + 'Support Markdown format for comment' => [ + -default => 0, + recommends( 'Text::Markdown' => '0' ), ], 'Support XML format for dump' => [ - -default => 1, - recommends( 'XML::LibXML' => '0' ), # Any XML? + -default => 0, + recommends( 'XML::LibXML' => '0' ), # Any XML? + ], + 'Support YAML format for dump' => [ + -default => 0, + recommends( 'YAML::Any' => '0' ), ], ); +# ================================================================ # internal dependencies -# requires 'Faktro::Schema::Factory' => '0'; - -# test_requires 'File::Temp' => '0'; -test_requires 'Test::Exception' => '0'; -test_requires 'Test::More' => '0.87_01'; # to use done_testing() -test_requires 'Test::Warn' => '0'; -# test_requires 'Time::HiRes' => '0'; # -> perl 5.007_003; - +# ================================================================ +# requires 'Faktro::Schema::Factory' => '0'; + +# ================================================================ +# dependencies for tests +# ================================================================ +# test_requires 'File::Temp' => '0'; +# test_requires 'Test::Exception' => '0'; # > Data::Model + test_requires 'Test::More' => '0.87_01'; # to use done_testing() + test_requires 'Test::Warn' => '0'; +# test_requires 'Time::HiRes' => '0'; # > perl 5.007_003; + +# Ark::Test + +# ================================================================ +# dependencies for author tests +# plan skip_all => 'xxxx required for testing xxxx' if ... +# ================================================================ +# test_requires 'Test::NoTabs' => '0'; +# test_requires 'Test::Output' => '0'; +# test_requires 'Test::Perl::Critic' => '1.094'; # for equivalent_modules +# test_requires 'Test::Pod' => '0'; +# test_requires 'Test::Pod::Coverage' => '0'; +# test_requires 'Test::Spelling' => '0'; +# test_requires 'Test::Synopsis' => '0'; +# test_requires 'Test::UseAllModules' => '0'; + +# ================================================================ +# tests +# ================================================================ use_test_base; -tests 't/*.t t/*/*.t t/*/*/*.t'; +tests 't/*.t t/*/*.t t/*/*/*.t'; +author_tests 'xt'; +# ================================================================ +# installation +# ================================================================ auto_include; +auto_install; +# ================================================================ +# META.yml writter +# ================================================================ WriteAll; __END__ + +# **************************************************************** +# POD +# **************************************************************** + =head1 NAME Makefile.PL - Makefile builder @@ -92,7 +149,7 @@ Makefile.PL - Makefile builder =head1 SYNOPSIS $ cpan -t . - $ make install + $ cpan -i . =head1 AUTHOR @@ -107,7 +164,7 @@ L =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/README b/README index de903e5..7464dc6 100644 --- a/README +++ b/README @@ -1,6 +1,6 @@ =head1 NAME -SimpleLinks - collection of links +SimpleLinks - sample application of collection of links (with Ark and Data::Model) =head1 INSTALLATION @@ -19,7 +19,7 @@ by the following command: finally, to deploy this application by the following command: - make install + cpan -i . =head1 DEPENDENCIES @@ -49,7 +49,7 @@ L =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/lib/SimpleLinks.pm b/lib/SimpleLinks.pm index 537bfb4..96a02b9 100644 --- a/lib/SimpleLinks.pm +++ b/lib/SimpleLinks.pm @@ -26,12 +26,12 @@ __END__ =head1 NAME -SimpleLinks - application of collection of links for sample of Ark and Data::Model +SimpleLinks - sample application of collection of links with Ark and Data::Model =head1 SYNOPSIS - blah blah blah + # blah blah blah =head1 DESCRIPTION @@ -51,7 +51,7 @@ L =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/lib/SimpleLinks/Schema/Column.pm b/lib/SimpleLinks/Schema/Column.pm index 2c10ef6..7c029e7 100644 --- a/lib/SimpleLinks/Schema/Column.pm +++ b/lib/SimpleLinks/Schema/Column.pm @@ -265,7 +265,7 @@ SimpleLinks::Schema::Column - column schemas と明示的に書き込むか、 $row->any_column($any_value); - $row->update_with_timestamp; + $row->_update_with_timestamp; という追加メソッドを使います。 @@ -284,7 +284,7 @@ L =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/lib/SimpleLinks/Schema/Mixin/Base.pm b/lib/SimpleLinks/Schema/Mixin/Base.pm index 892bf14..de94d2e 100644 --- a/lib/SimpleLinks/Schema/Mixin/Base.pm +++ b/lib/SimpleLinks/Schema/Mixin/Base.pm @@ -20,8 +20,8 @@ use Carp qw(); # miscellaneous methods # **************************************************************** -sub _alias_to_real { - my ($schema, $option, $alias) = @_; +sub __alias_to_real { + my ($invocant, $option, $alias) = @_; my %new_option = %$option; @@ -35,8 +35,8 @@ sub _alias_to_real { return \%new_option; } -sub _separate_taxonomy_from { - my ($schema, $option, $taxonomy_attributes) = @_; +sub __separate_taxonomy_from { + my ($invocant, $option, $taxonomy_attributes) = @_; my %new_option = %$option; my %taxonomy_option; @@ -87,7 +87,7 @@ L =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/lib/SimpleLinks/Schema/Mixin/Category.pm b/lib/SimpleLinks/Schema/Mixin/Category.pm index 23e9e5c..aaf8f5d 100644 --- a/lib/SimpleLinks/Schema/Mixin/Category.pm +++ b/lib/SimpleLinks/Schema/Mixin/Category.pm @@ -23,6 +23,7 @@ use base qw( # **************************************************************** use Carp qw(); +use List::MoreUtils qw(none); use List::Util qw(first); @@ -32,17 +33,17 @@ use List::Util qw(first); sub register_method { +{ + add_category => \&add_category, + create_category => \&add_category, categories => \&all_categories, all_categories => \&all_categories, count_categories => \&count_categories, - add_category => \&add_category, - create_category => \&add_category, - edit_category => \&edit_category, - update_category => \&edit_category, - remove_category => \&remove_category, - delete_category => \&remove_category, - _alias_columns_of_category => \&alias_columns_of_category, - _add_website_category => \&add_website_category, + __edit_category => \&__edit_category, + __update_category => \&__edit_category, + __remove_category => \&__remove_category, + __delete_category => \&__remove_category, + __alias_columns_of_category => \&__alias_columns_of_category, + __add_website_category => \&__add_website_category, }; } @@ -51,6 +52,22 @@ sub register_method { # additional methods # **************************************************************** +sub add_category { + my ($schema, $option) = @_; + + my $modified_option + = __PACKAGE__->__alias_to_real($schema, $option); + __PACKAGE__->__check_same_column + ($schema, 'taxonomy_name', $modified_option); + __PACKAGE__->__check_same_column + ($schema, 'taxonomy_slug', $modified_option); + + my $category = $schema->set(category => $modified_option); + __PACKAGE__->__build_parent_recursively($schema, $category); + + return $category; +} + sub all_categories { my $schema = shift; @@ -67,41 +84,25 @@ sub count_categories { return scalar(my @categories = $schema->all_categories); } -sub add_category { - my ($schema, $option) = @_; - - my $modified_option - = __PACKAGE__->_alias_to_real($schema, $option); - __PACKAGE__->_check_same_column - ($schema, 'taxonomy_name', $modified_option); - __PACKAGE__->_check_same_column - ($schema, 'taxonomy_slug', $modified_option); - - my $category = $schema->set(category => $modified_option); - __PACKAGE__->_build_parent_recursively($schema, $category); - - return $category; -} - -sub _build_parent_recursively { +sub __build_parent_recursively { my ($class, $schema, $category) = @_; my $parent_category = $category->parent; if ($parent_category) { $parent_category->_build_children_count; $parent_category->_build_descendants_count; - $parent_category->update; # SUPER::update ?? - __PACKAGE__->_build_parent_recursively($schema, $parent_category); + $parent_category->_internal_update; + __PACKAGE__->__build_parent_recursively($schema, $parent_category); } return; } -sub _alias_to_real { +sub __alias_to_real { my ($class, $schema, $option) = @_; - my $modified_option = $class->SUPER::_alias_to_real - ($option, $schema->_alias_columns_of_category); + my $modified_option = $class->SUPER::__alias_to_real + ($option, $schema->__alias_columns_of_category); if (exists $modified_option->{parent}) { if (defined $modified_option->{parent}) { $modified_option->{parent_id} = $modified_option->{parent}->id; @@ -115,12 +116,16 @@ sub _alias_to_real { return $modified_option; } -sub _check_same_column { +sub __check_same_column { my ($class, $schema, $column, $option) = @_; + my %is_not_same_id + = exists $option->{id} ? (id => { '!=' => $option->{id} } ) + : (); my @category_of_same_column = $schema->get(category => { where => [ $column => $option->{$column}, + %is_not_same_id, ], }); return unless @category_of_same_column; @@ -132,17 +137,17 @@ sub _check_same_column { require Data::Dumper; local $Data::Dumper::Indent = 1; - __PACKAGE__->_throw_exception_from_category( + __PACKAGE__->__throw_exception_from_category( sprintf('column %s is not unique', $column), Data::Dumper::Dumper($option), - __PACKAGE__->_dump_contestant($contestant), + __PACKAGE__->__dump_contestant($contestant), ); } -sub _throw_exception_from_category { - my ($schema, $reason, $option, $additional_info) = @_; +sub __throw_exception_from_category { + my ($class, $reason, $option, $additional_info) = @_; - Carp::croak sprintf <<"TRACE", $reason, $option, $additional_info; + Carp::croak sprintf <<"TRACE", $reason, $option, $additional_info || q{}; **** { SimpleLinks::Schema::Mixin::Category 's Exception **** Reason : %s @@ -152,7 +157,7 @@ Attributes : TRACE } -sub _dump_contestant { +sub __dump_contestant { my ($class, $contestant) = @_; return sprintf <<"TRACE", Data::Dumper::Dumper($contestant); @@ -161,46 +166,61 @@ sub _dump_contestant { TRACE } -sub alias_columns_of_category { +sub __alias_columns_of_category { my $schema = shift; return { - @{ $schema->_alias_columns_of_taxonomy }, - @{ $schema->_alias_columns_of_common }, + @{ $schema->__alias_columns_of_taxonomy }, + @{ $schema->__alias_columns_of_common }, }; } -sub add_website_category { +sub __add_website_category { my ($schema, $option) = @_; return $schema->set(website_category => $option); } -# override $category->update ? -sub edit_category { - my ($schema, $category) = @_; +# overrided $category->update +sub __edit_category { + my ($schema_class, $category) = @_; - __PACKAGE__->_check_same_column - ($schema, 'taxonomy_name', $category); - __PACKAGE__->_check_same_column - ($schema, 'taxonomy_slug', $category); + my $schema = $schema_class->new; - # to do: create method '_check_reverse_filiation' - die 'xxx' - # to do: create method 'is_child_of' - if grep { - $category->parent->id eq $_->id - } $category->children; + __PACKAGE__->__check_same_column + ($schema, 'taxonomy_name', $category->get_columns); + __PACKAGE__->__check_same_column + ($schema, 'taxonomy_slug', $category->get_columns); + __PACKAGE__->__check_reverse_filiation + ($schema, $category); - $category->SUPER::update; # can I call? - __PACKAGE__->_build_parent_recursively($schema, $category); + $category->_internal_update; + __PACKAGE__->__build_parent_recursively($schema, $category); return $category; } +sub __check_reverse_filiation { + my ($class, $schema, $category) = @_; + + my $parent_id = $category->parent_id; + + return unless defined $parent_id; + return if none { + $_ eq $parent_id; + } $category->child_ids; + + require Data::Dumper; + local $Data::Dumper::Indent = 1; + __PACKAGE__->__throw_exception_from_category( + 'category at once parent and child', + Data::Dumper::Dumper($category), + ); +} + +# overrided $category->delete # cannot override $schema->delete(category => $category->id)! -# override $category->delete ? -sub remove_category { +sub __remove_category { my ($schema, $category) = @_; # to do: create method '_check_leaf_deleting' @@ -209,7 +229,7 @@ sub remove_category { my $parent_category = $category->parent; $category->SUPER::delete; # can I call? - __PACKAGE__->_build_parent_recursively($schema, $parent_category); + __PACKAGE__->__build_parent_recursively($schema, $parent_category); return; } @@ -242,6 +262,31 @@ SimpleLinks::Schema::Mixin::Category - blah blah blah +=head1 METHODS + +=head2 add_category + +Creates a new category row to C table +on the regulation database. + +Returns created C row. + +=head2 all_categories + +Returns all category rows from C table +on the regulation database. + +=head2 count_categories + +Returns number of category rows in C table +on the regulation database. + +=head2 register_method + +B. +For L mechanism. + + =head1 AUTHOR =over 4 @@ -254,7 +299,7 @@ L =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/lib/SimpleLinks/Schema/Mixin/Common.pm b/lib/SimpleLinks/Schema/Mixin/Common.pm index d9faa8a..52d0125 100644 --- a/lib/SimpleLinks/Schema/Mixin/Common.pm +++ b/lib/SimpleLinks/Schema/Mixin/Common.pm @@ -23,8 +23,8 @@ use DateTime; sub register_method { +{ - _update_with_timestamp => \&update_with_timestamp, - _alias_columns_of_common => \&alias_columns_of_common, + __update_with_timestamp => \&__update_with_timestamp, + __alias_columns_of_common => \&__alias_columns_of_common, }; } @@ -34,7 +34,7 @@ sub register_method { # **************************************************************** # common_updated_on以外のカラムが編集されていたらcommon_updated_onも編集する -sub update_with_timestamp { +sub __update_with_timestamp { my ($schema, $row, $timestamp_column) = @_; return @@ -48,7 +48,7 @@ sub update_with_timestamp { return $row; } -sub alias_columns_of_common { +sub __alias_columns_of_common { my $scalar = shift; return [ @@ -85,6 +85,16 @@ SimpleLinks::Schema::Mixin::Common - blah blah blah + + +=head1 METHODS + +=head2 register_method + +B. +For L mechanism. + + =head1 AUTHOR =over 4 @@ -97,7 +107,7 @@ L =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/lib/SimpleLinks/Schema/Mixin/Tag.pm b/lib/SimpleLinks/Schema/Mixin/Tag.pm index a31519e..5221540 100644 --- a/lib/SimpleLinks/Schema/Mixin/Tag.pm +++ b/lib/SimpleLinks/Schema/Mixin/Tag.pm @@ -35,8 +35,8 @@ sub register_method { all_tags => \&all_tags, count_tags => \&count_tags, add_tag => \&add_tag, - _alias_columns_of_tag => \&alias_columns_of_tag, - _add_website_tag => \&add_website_tag, + __alias_columns_of_tag => \&__alias_columns_of_tag, + __add_website_tag => \&__add_website_tag, }; } @@ -65,21 +65,21 @@ sub add_tag { my ($schema, $option) = @_; return $schema->set(tag => - __PACKAGE__->SUPER::_alias_to_real - ($option, $schema->_alias_columns_of_tag) + __PACKAGE__->SUPER::__alias_to_real + ($option, $schema->__alias_columns_of_tag) ); } -sub alias_columns_of_tag { +sub __alias_columns_of_tag { my $schema = shift; return { - @{ $schema->_alias_columns_of_taxonomy }, - @{ $schema->_alias_columns_of_common }, + @{ $schema->__alias_columns_of_taxonomy }, + @{ $schema->__alias_columns_of_common }, }; } -sub add_website_tag { +sub __add_website_tag { my ($schema, $option) = @_; return $schema->set(website_tag => $option); @@ -112,6 +112,36 @@ SimpleLinks::Schema::Mixin::Tag - blah blah blah +=head1 METHODS + +=head2 add_tag + +Creates a new tag row to C table +on the regulation database. + +Returns created C row. + +=head2 all_tags + +Returns all tag rows from C table +on the regulation database. + +=head2 count_tags + +Returns number of tag rows in C table +on the regulation database. + +=head2 remove_tag + +Deletes a existent tag row in C table +on the regulation database. + +=head2 register_method + +B. +For L mechanism. + + =head1 AUTHOR =over 4 @@ -124,7 +154,7 @@ L =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/lib/SimpleLinks/Schema/Mixin/Taxonomy.pm b/lib/SimpleLinks/Schema/Mixin/Taxonomy.pm index ee2fc60..03a3d23 100644 --- a/lib/SimpleLinks/Schema/Mixin/Taxonomy.pm +++ b/lib/SimpleLinks/Schema/Mixin/Taxonomy.pm @@ -23,12 +23,12 @@ use Scalar::Util qw(); sub register_method { +{ - _website_ids => \&website_ids_of_taxonomy, - _websites => \&websites_of_taxonomy, - __build_websites_count => \&_build_websites_count, - _alias_columns_of_taxonomy => \&alias_columns_of_taxonomy, - add_taxonomy => \&add_taxonomy, - delete_taxonomy => \&delete_taxonomy, + __add_taxonomy => \&__add_taxonomy, + __delete_taxonomy => \&__delete_taxonomy, + _website_ids => \&__website_ids_of_taxonomy, + _websites => \&__websites_of_taxonomy, + __build_websites_count => \&__build_websites_count, + __alias_columns_of_taxonomy => \&__alias_columns_of_taxonomy, }; } @@ -37,7 +37,7 @@ sub register_method { # additional methods # **************************************************************** -sub website_ids_of_taxonomy { +sub __website_ids_of_taxonomy { my ($schema, $taxonomy) = @_; (my $table_name = Scalar::Util::blessed $taxonomy || q{}) @@ -57,7 +57,7 @@ sub website_ids_of_taxonomy { }); } -sub websites_of_taxonomy { +sub __websites_of_taxonomy { my ($schema, $taxonomy) = @_; my @website_ids = $taxonomy->website_ids($taxonomy); @@ -66,14 +66,14 @@ sub websites_of_taxonomy { return $schema->filter_websites(\@website_ids); } -sub _build_websites_count { +sub __build_websites_count { my ($schema, $taxonomy) = @_; return $taxonomy->count_websites ( scalar( my @websites = $taxonomy->websites($taxonomy) ) ); } -sub alias_columns_of_taxonomy { +sub __alias_columns_of_taxonomy { my $schema = shift; return [ @@ -84,7 +84,7 @@ sub alias_columns_of_taxonomy { ]; } -sub add_taxonomy { +sub __add_taxonomy { my ($schema, $website_id, $option) = @_; if (defined $option->{categories}) { @@ -93,7 +93,7 @@ sub add_taxonomy { Scalar::Util::blessed $_ ? $_->id : $_ } @{ $option->{categories} } ) { - $schema->_add_website_category({ + $schema->__add_website_category({ website_id => $website_id, category_id => $category_id, }); @@ -105,7 +105,7 @@ sub add_taxonomy { Scalar::Util::blessed $_ ? $_->id : $_ } @{ $option->{tags} } ) { - $schema->_add_website_tag({ + $schema->__add_website_tag({ website_id => $website_id, tag_id => $tag_id, }); @@ -115,7 +115,7 @@ sub add_taxonomy { return; } -sub delete_taxonomy { +sub __delete_taxonomy { } @@ -147,6 +147,14 @@ SimpleLinks::Schema::Mixin::Taxonomy - blah blah blah +=head1 METHODS + +=head2 register_method + +B. +For L mechanism. + + =head1 SEE ALSO =over 4 @@ -176,7 +184,7 @@ L =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/lib/SimpleLinks/Schema/Mixin/Website.pm b/lib/SimpleLinks/Schema/Mixin/Website.pm index 72234eb..78b0b97 100644 --- a/lib/SimpleLinks/Schema/Mixin/Website.pm +++ b/lib/SimpleLinks/Schema/Mixin/Website.pm @@ -36,7 +36,7 @@ sub register_method { filter_websites => \&filter_websites, count_websites => \&count_websites, add_website => \&add_website, - _alias_columns_of_website => \&alias_columns_of_website, + __alias_columns_of_website => \&__alias_columns_of_website, # ... }; } @@ -46,6 +46,25 @@ sub register_method { # additional methods # **************************************************************** +sub add_website { + my ($schema, $option) = @_; + + my $modified_option + = __PACKAGE__->SUPER::__alias_to_real + ($option, $schema->__alias_columns_of_website); + ($modified_option, my $taxonomy_option) + = $schema->SUPER::__separate_taxonomy_from + ($modified_option, [qw(categories tags)]); + + my $website = $schema->set(website => $modified_option); + + if (keys %$taxonomy_option) { + $schema->__add_taxonomy($website->id, $taxonomy_option); + } + + return $website; +} + sub all_websites { my $schema = shift; @@ -70,54 +89,35 @@ sub count_websites { return scalar(my @websites = $schema->all_websites); } -sub add_website { - my ($schema, $option) = @_; - - my $modified_option - = __PACKAGE__->SUPER::_alias_to_real - ($option, $schema->_alias_columns_of_website); - ($modified_option, my $taxonomy_option) - = $schema->SUPER::_separate_taxonomy_from - ($modified_option, [qw(categories tags)]); - - my $website = $schema->set(website => $modified_option); - - if (keys %$taxonomy_option) { - $schema->add_taxonomy($website->id, $taxonomy_option); - } - - return $website; -} - -sub alias_columns_of_website { +sub __alias_columns_of_website { my $schema = shift; return { - @{ $schema->_alias_columns_of_taxonomy }, - @{ $schema->_alias_columns_of_common }, + @{ $schema->__alias_columns_of_taxonomy }, + @{ $schema->__alias_columns_of_common }, }; } # $website_row->add_categories -sub add_categories { +sub __add_categories { } -sub delete_categories { +sub __delete_categories { } -sub add_tags { +sub __add_tags { } -sub add_relations { +sub __add_relations { } -sub delete_website { +sub __delete_website { } -sub delete_relations { +sub __delete_relations { } -sub modify_relation { +sub __modify_relation { } @@ -148,6 +148,36 @@ SimpleLinks::Schema::Mixin::Website - blah blah blah +=head1 METHODS + +=head2 add_website + +Creates a new website row to C table +on the regulation database. + +Returns created C row. + +=head2 all_websites + +Returns all website rows from C table +on the regulation database. + +=head2 filter_websites + +Returns filtered website rows from C table +on the regulation database. + +=head2 count_websites + +Returns number of website rows in C table +on the regulation database. + +=head2 register_method + +B. +For L mechanism. + + =head1 AUTHOR =over 4 @@ -160,7 +190,7 @@ L =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/lib/SimpleLinks/Schema/Table.pm b/lib/SimpleLinks/Schema/Table.pm index 7b0b177..56fd36c 100644 --- a/lib/SimpleLinks/Schema/Table.pm +++ b/lib/SimpleLinks/Schema/Table.pm @@ -31,6 +31,7 @@ use Data::Model::Mixin modules => [ '+SimpleLinks::Schema::Mixin::Website', ]; use Data::Model::Schema sugar => 'simplelinks'; +use List::MoreUtils qw(any); # **************************************************************** @@ -56,14 +57,14 @@ install_model website => schema { utf8_column 'website.owner'; utf8_column 'website.introduction'; utf8_column 'website.comment'; - __PACKAGE__->columns_of_common; + __PACKAGE__->_columns_of_common; unique 'uri'; - __PACKAGE__->website_has_many_categories; - __PACKAGE__->website_has_many_tags; + __PACKAGE__->_website_has_many_categories; + __PACKAGE__->_website_has_many_tags; - __PACKAGE__->can_update_with_timestamp; + __PACKAGE__->_can_update_with_timestamp; }; # ================================================================ @@ -76,17 +77,18 @@ install_model category => schema { column 'category.parent_id'; column 'category.count_children'; column 'category.count_descendants'; - __PACKAGE__->columns_of_taxonomy; - __PACKAGE__->columns_of_common; + __PACKAGE__->_columns_of_taxonomy; + __PACKAGE__->_columns_of_common; - __PACKAGE__->category_has_many_children; - __PACKAGE__->category_has_many_descendants; - __PACKAGE__->category_might_belong_to_parent; - __PACKAGE__->many_taxonomy_to_many_websites; + __PACKAGE__->_category_has_many_children; + __PACKAGE__->_category_has_many_descendants; + __PACKAGE__->_category_might_belong_to_parent; + __PACKAGE__->_many_taxonomy_to_many_websites; - __PACKAGE__->must_update_with_rebuild; + __PACKAGE__->_can_alternative_update; + __PACKAGE__->_must_update_with_rebuild; - __PACKAGE__->can_update_with_timestamp; + __PACKAGE__->_can_update_with_timestamp; }; # ================================================================ @@ -98,9 +100,9 @@ install_model website_category => schema { column 'website_category.id' => { auto_increment => 1 }; column 'website.id'; column 'category.id'; - __PACKAGE__->columns_of_common; + __PACKAGE__->_columns_of_common; - __PACKAGE__->can_update_with_timestamp; + __PACKAGE__->_can_update_with_timestamp; }; # ================================================================ @@ -110,15 +112,15 @@ install_model tag => schema { key 'id'; column 'tag.id' => { auto_increment => 1 }; - __PACKAGE__->columns_of_taxonomy; - __PACKAGE__->columns_of_common; + __PACKAGE__->_columns_of_taxonomy; + __PACKAGE__->_columns_of_common; unique 'taxonomy_name'; unique 'taxonomy_slug'; - __PACKAGE__->many_taxonomy_to_many_websites; + __PACKAGE__->_many_taxonomy_to_many_websites; - __PACKAGE__->can_update_with_timestamp; + __PACKAGE__->_can_update_with_timestamp; }; # ================================================================ @@ -130,9 +132,9 @@ install_model website_tag => schema { column 'website_tag.id' => { auto_increment => 1 }; column 'website.id'; column 'tag.id'; - __PACKAGE__->columns_of_common; + __PACKAGE__->_columns_of_common; - __PACKAGE__->can_update_with_timestamp; + __PACKAGE__->_can_update_with_timestamp; }; @@ -140,7 +142,7 @@ install_model website_tag => schema { # universal columns # **************************************************************** -sub columns_of_taxonomy { +sub _columns_of_taxonomy { my $schema = shift; column 'taxonomy.slug'; @@ -148,18 +150,18 @@ sub columns_of_taxonomy { utf8_column 'taxonomy.description'; column 'taxonomy.count_websites'; - $schema->alias_columns_of_taxonomy; + $schema->_alias_columns_of_taxonomy; return; } -sub columns_of_common { +sub _columns_of_common { my $schema = shift; column 'common.created_on'; column 'common.updated_on'; - $schema->alias_columns_of_common; + $schema->_alias_columns_of_common; return; } @@ -169,18 +171,18 @@ sub columns_of_common { # universal alias columns # **************************************************************** -sub alias_columns_of_taxonomy { +sub _alias_columns_of_taxonomy { my $schema = shift; - $schema->_set_alias_columns($schema->_alias_columns_of_taxonomy); + $schema->_set_alias_columns($schema->__alias_columns_of_taxonomy); return; } -sub alias_columns_of_common { +sub _alias_columns_of_common { my $schema = shift; - $schema->_set_alias_columns($schema->_alias_columns_of_common); + $schema->_set_alias_columns($schema->__alias_columns_of_common); return; } @@ -202,7 +204,7 @@ sub _set_alias_columns { # relationships # **************************************************************** -sub website_has_many_categories { +sub _website_has_many_categories { my $schema = shift; add_method category_ids => sub { @@ -227,7 +229,7 @@ sub website_has_many_categories { return; } -sub website_has_many_tags { +sub _website_has_many_tags { my $schema = shift; add_method tag_ids => sub { @@ -252,7 +254,7 @@ sub website_has_many_tags { return; } -sub category_has_many_children { +sub _category_has_many_children { my $schema = shift; add_method child_ids => sub { @@ -281,10 +283,18 @@ sub category_has_many_children { return not $_[0]->count_children; }; + add_method is_child_of => sub { + my ($category, $parent_candidate) = @_; + + return any { + $category->id eq $_; + } $parent_candidate->child_ids; + }; + return; } -sub category_has_many_descendants { +sub _category_has_many_descendants { my $schema = shift; add_method descendant_ids => sub { @@ -313,7 +323,7 @@ sub category_has_many_descendants { return; } -sub category_might_belong_to_parent { +sub _category_might_belong_to_parent { my $schema = shift; add_method parent => sub { @@ -328,20 +338,39 @@ sub category_might_belong_to_parent { return not defined $_[0]->parent_id; }; + add_method is_parent_of => sub { + my ($category, $child_candidate) = @_; + + return any { + $_->id eq $child_candidate->parent_id; + } $category->children; + }; + + return; +} + +sub _must_update_with_rebuild { + my $schema = shift; + + add_method update => sub { + $schema->__edit_category($_[0]); + }; + return; } -sub must_update_with_rebuild { +sub _can_alternative_update { my $schema = shift; - add_method update_xxxxx => sub { - $schema->edit_category($_[0]); + add_method _internal_update => sub { + my $row = shift; + $row->{model}->update($row, @_); }; return; } -sub many_taxonomy_to_many_websites { +sub _many_taxonomy_to_many_websites { my $schema = shift; add_method website_ids => sub { @@ -364,11 +393,11 @@ sub many_taxonomy_to_many_websites { # miscellaneous methods # **************************************************************** -sub can_update_with_timestamp { +sub _can_update_with_timestamp { my $schema = shift; - add_method update_with_timestamp => sub { - $schema->_update_with_timestamp($_[0], 'common_updated_on'); + add_method _update_with_timestamp => sub { + $schema->__update_with_timestamp($_[0], 'common_updated_on'); }; } @@ -392,14 +421,17 @@ SimpleLinks::Schema::Table - table schemas =head1 SYNOPSIS -=head2 Directly (from CLI) + # **** Directly (from CLI) **** - use Faktro::Schema::Factory; + package SimpleLinks::CLI::Foobar; use Encode; use FindBin; use YAML::Any; + use lib 'extlib'; + use Faktro::Schema::Factory; + my $model = Faktro::Schema::Factory->new( backend => 'SQLite', model_class => 'SimpleLinks::Schema::Table', @@ -410,14 +442,14 @@ SimpleLinks::Schema::Table - table schemas my $website = $model->lookup( website => 1 ); print Encode::decode_utf8( Dump $website ); - 1; - __END__ -=head2 Indirectry (via Ark) + # **** Indirectry (via Ark) **** + + # ---- Ark model ---- package SimpleLinks::Web::Model::Links; - use Ark 'Model::Adaptor'; + use Ark 'Model::Adaptor'; # automatically turn on strict & warnings __PACKAGE__->config( class => 'Faktro::Schema::Factory', @@ -431,15 +463,14 @@ SimpleLinks::Schema::Table - table schemas deref => 1, ); - 1; - __END__ + # ---- Ark controller ---- package SimpleLinks::Web::Controller::Root; use Encode; use YAML::Any; - use Ark 'Controller'; + use Ark 'Controller'; # automatically turn on strict & warnings has '+namespace' => ( default => q{}, @@ -451,15 +482,10 @@ SimpleLinks::Schema::Table - table schemas my $model = $c->model('Links'); my $website = $model->lookup( website => 1 ); - $c->res->header(content_type => 'text/plain'); - $c->res->body(Encode::decode_utf8(Dump $website)); + $c->res->header( content_type => 'text/plain' ); + $c->res->body( Encode::decode_utf8(Dump $website) ); } - # ... - - 1; - __END__ - =head1 DESCRIPTION @@ -467,9 +493,10 @@ SimpleLinks::Schema::Table - table schemas Lでは、LのCやDBのテーブル生成などを、ラッパークラスのLで行っています。勿論、Lの通りに、テーブルスキーマである本モジュール自体に処理を実装しても構いません。 -=head2 Memorandum -=head3 auto update +=head1 MEMORANDUM + +=head2 Auto update C<< $row->update >>の替わりにC<< $row->update_with_timestamp >>を使うことにより、暗黙的に更新日時を設定出来ます。 @@ -484,11 +511,11 @@ C<< $row->update >>を上書きして、以下のように暗黙的に更新日 }; -=head3 alias_colun +=head2 Alias coluns C<< $model->set >>時にはC<< alias_column >>されたエイリアスでの格納は不可能（？）。 -=head3 relationship +=head2 Relationship C, C, C, C, Cは、単なる命名規則に過ぎません。 @@ -508,7 +535,7 @@ L =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/lib/SimpleLinks/Service/Links.pm b/lib/SimpleLinks/Service/Links.pm index 2758213..f13f5d4 100644 --- a/lib/SimpleLinks/Service/Links.pm +++ b/lib/SimpleLinks/Service/Links.pm @@ -75,7 +75,7 @@ SimpleLinks::Service::Links - =head1 SYNOPSIS - blah blah blah + # blah blah blah =head1 DESCRIPTION @@ -95,7 +95,7 @@ L =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/lib/SimpleLinks/Web.pm b/lib/SimpleLinks/Web.pm index 7f27c3b..0d10df3 100644 --- a/lib/SimpleLinks/Web.pm +++ b/lib/SimpleLinks/Web.pm @@ -1,13 +1,6 @@ package SimpleLinks::Web; -# **************************************************************** -# class variables -# **************************************************************** - -our $VERSION = '0.00_00'; - - # **************************************************************** # MOP # **************************************************************** @@ -20,6 +13,15 @@ __PACKAGE__->config( __PACKAGE__->meta->make_immutable; +no Ark; + + +# **************************************************************** +# class variables +# **************************************************************** + +our $VERSION = '0.00_00'; + # **************************************************************** # return true @@ -40,7 +42,7 @@ SimpleLinks::Web - =head1 SYNOPSIS - blah blah blah + # blah blah blah =head1 DESCRIPTION @@ -60,7 +62,7 @@ L =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/lib/SimpleLinks/Web/Controller/Root.pm b/lib/SimpleLinks/Web/Controller/Root.pm index 6402ae6..06eecca 100644 --- a/lib/SimpleLinks/Web/Controller/Root.pm +++ b/lib/SimpleLinks/Web/Controller/Root.pm @@ -1,6 +1,13 @@ package SimpleLinks::Web::Controller::Root; +# **************************************************************** +# general dependencies +# **************************************************************** + +use Exception::Class::TryCatch; + + # **************************************************************** # MOP # **************************************************************** @@ -11,32 +18,50 @@ has '+namespace' => ( default => '', ); +# with Localizable + +__PACKAGE__->meta->make_immutable; + # **************************************************************** # actions # **************************************************************** # default 404 handler -sub default :Path :Args { +sub default : Path Args { my ($self, $c) = @_; $c->res->status(404); - $c->res->body('404 Not Found'); + $c->view('MT')->template('errors/404'); } -sub index :Path :Args(0) { +sub index : Path Args(0) { my ($self, $c) = @_; - my $model = $c->model('Links'); - my $website = $model->lookup( website => 1 ); + try eval { + # test + my $model = $c->model('Links'); + my $website = $model->lookup( website => 1 ); + + use YAML::Any; + use Encode; + $c->res->header(content_type => 'text/plain; charset=UTF-8'); + $c->res->body(Encode::decode_utf8(Dump $website)); + + # $c->res->body('Ark Default Index'); + }; + if (catch my $exception) { + $c->res->status(500); + $c->view('MT')->template('errors/500'); + } +} - # test - use YAML::Any; - use Encode; - $c->res->header(content_type => 'text/plain; charset=UTF-8'); - $c->res->body(Encode::decode_utf8(Dump $website)); +sub end : Private { + my ($self, $c) = @_; - # $c->res->body('Ark Default Index'); + unless ($c->res->body or $c->res->status =~ m{ \A 3\d\d }xms) { + $c->forward( $c->view('MT') ); + } } @@ -54,12 +79,12 @@ __END__ =head1 NAME -SimpleLinks::Web::Model::Links - +SimpleLinks::Web::Controller::Root - =head1 SYNOPSIS - blah blah blah + # blah blah blah =head1 DESCRIPTION @@ -67,6 +92,21 @@ SimpleLinks::Web::Model::Links - blah blah blah +=head1 ACTIONS + +=head2 default + +Ark default handler (404 Not found). + +=head2 index + +Index page (C). + +=head2 end + +End action. Renders content with any template. + + =head1 AUTHOR =over 4 @@ -79,7 +119,7 @@ L =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/lib/SimpleLinks/Web/Model/Links.pm b/lib/SimpleLinks/Web/Model/Links.pm index 3cbcd40..582dd4e 100644 --- a/lib/SimpleLinks/Web/Model/Links.pm +++ b/lib/SimpleLinks/Web/Model/Links.pm @@ -41,7 +41,7 @@ SimpleLinks::Web::Model::Links - =head1 SYNOPSIS - blah blah blah + # blah blah blah =head1 DESCRIPTION @@ -61,7 +61,7 @@ L =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/lib/SimpleLinks/Web/View/JSON.pm b/lib/SimpleLinks/Web/View/JSON.pm new file mode 100644 index 0000000..177d7ad --- /dev/null +++ b/lib/SimpleLinks/Web/View/JSON.pm @@ -0,0 +1,65 @@ +package SimpleLinks::Web::View::JSON; + +use strict; +use warnings; + + +# **************************************************************** +# MOP +# **************************************************************** + + + +# **************************************************************** +# miscellaneous methods +# **************************************************************** + + + +# **************************************************************** +# return true +# **************************************************************** + +1; +__END__ + + +# **************************************************************** +# POD +# **************************************************************** + +=head1 NAME + +SimpleLinks::Web::View::JSON - + + +=head1 SYNOPSIS + + # blah blah blah + + +=head1 DESCRIPTION + +blah blah blah + + +=head1 AUTHOR + +=over 4 + +=item MORIYA Masaki ("Gardejo") + +C<< >>, +L + +=back + + +=head1 LICENSE AND COPYRIGHT + +Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), +L. + +This library is free software; +you can redistribute it and/or modify it under the same terms as Perl itself. +See L and L. diff --git a/lib/SimpleLinks/Web/View/MT.pm b/lib/SimpleLinks/Web/View/MT.pm new file mode 100644 index 0000000..97cbbf1 --- /dev/null +++ b/lib/SimpleLinks/Web/View/MT.pm @@ -0,0 +1,92 @@ +package SimpleLinks::Web::View::MT; + + +# **************************************************************** +# MOP +# **************************************************************** + +use Ark 'View::MT'; # automatically turn on strict & warnings + +has '+options' => ( + default => sub { + my $self = shift; + + my $context = sub { $self->context }; + my $stash = sub { $self->context->stash }; + # my $user = sub { $self->context->user }; + # my $localizer = sub { $self->context->stash->{localizer} }; + + return { + tag_start => '[%', + tag_end => '%]', + line_start => '%', + template_args => { + c => $context, + stash => $stash, + s => $stash, + # user => $user, + # u => $user, + # localizer => $localizer, + # l => $localizer, + }, + }; + }, +); + +no Ark; +__PACKAGE__->meta->make_immutable; + + +# **************************************************************** +# miscellaneous methods +# **************************************************************** + + + +# **************************************************************** +# return true +# **************************************************************** + +1; +__END__ + + +# **************************************************************** +# POD +# **************************************************************** + +=head1 NAME + +SimpleLinks::Web::View::MT - + + +=head1 SYNOPSIS + + # blah blah blah + + +=head1 DESCRIPTION + +blah blah blah + + +=head1 AUTHOR + +=over 4 + +=item MORIYA Masaki ("Gardejo") + +C<< >>, +L + +=back + + +=head1 LICENSE AND COPYRIGHT + +Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), +L. + +This library is free software; +you can redistribute it and/or modify it under the same terms as Perl itself. +See L and L. diff --git a/lib/SimpleLinks/Web/View/XML.pm b/lib/SimpleLinks/Web/View/XML.pm new file mode 100644 index 0000000..d9a7555 --- /dev/null +++ b/lib/SimpleLinks/Web/View/XML.pm @@ -0,0 +1,65 @@ +package SimpleLinks::Web::View::XML; + +use strict; +use warnings; + + +# **************************************************************** +# MOP +# **************************************************************** + + + +# **************************************************************** +# miscellaneous methods +# **************************************************************** + + + +# **************************************************************** +# return true +# **************************************************************** + +1; +__END__ + + +# **************************************************************** +# POD +# **************************************************************** + +=head1 NAME + +SimpleLinks::Web::View::XML - + + +=head1 SYNOPSIS + + # blah blah blah + + +=head1 DESCRIPTION + +blah blah blah + + +=head1 AUTHOR + +=over 4 + +=item MORIYA Masaki ("Gardejo") + +C<< >>, +L + +=back + + +=head1 LICENSE AND COPYRIGHT + +Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), +L. + +This library is free software; +you can redistribute it and/or modify it under the same terms as Perl itself. +See L and L. diff --git a/lib/SimpleLinks/Web/View/YAML.pm b/lib/SimpleLinks/Web/View/YAML.pm new file mode 100644 index 0000000..284d373 --- /dev/null +++ b/lib/SimpleLinks/Web/View/YAML.pm @@ -0,0 +1,66 @@ +package SimpleLinks::Web::View::YAML; + +use strict; +use warnings; + + +# **************************************************************** +# MOP +# **************************************************************** + +# Ark::View::Serializerを書くかも。YAML, JSON, XML辺り。 + + +# **************************************************************** +# miscellaneous methods +# **************************************************************** + + + +# **************************************************************** +# return true +# **************************************************************** + +1; +__END__ + + +# **************************************************************** +# POD +# **************************************************************** + +=head1 NAME + +SimpleLinks::Web::View::JSON - + + +=head1 SYNOPSIS + + # blah blah blah + + +=head1 DESCRIPTION + +blah blah blah + + +=head1 AUTHOR + +=over 4 + +=item MORIYA Masaki ("Gardejo") + +C<< >>, +L + +=back + + +=head1 LICENSE AND COPYRIGHT + +Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), +L. + +This library is free software; +you can redistribute it and/or modify it under the same terms as Perl itself. +See L and L. diff --git a/script/simplelinks.cgi b/script/simplelinks.cgi index d34feb1..174260f 100644 --- a/script/simplelinks.cgi +++ b/script/simplelinks.cgi @@ -121,7 +121,7 @@ L =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/script/simplelinks_server.pl b/script/simplelinks_server.pl index 395dfc0..6843009 100644 --- a/script/simplelinks_server.pl +++ b/script/simplelinks_server.pl @@ -170,7 +170,7 @@ =head1 AUTHOR =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/t/00_compile.t b/t/00_compile.t deleted file mode 100644 index 965ba8d..0000000 --- a/t/00_compile.t +++ /dev/null @@ -1,4 +0,0 @@ -use strict; -use Test::More tests => 1; - -BEGIN { use_ok 'SimpleLinks::Web' } diff --git a/t/00_startup/00_compile.t b/t/00_startup/00_compile.t index 965ba8d..9a6143f 100644 --- a/t/00_startup/00_compile.t +++ b/t/00_startup/00_compile.t @@ -1,4 +1,16 @@ +#!perl -T + use strict; +use warnings; +use local::lib; + use Test::More tests => 1; -BEGIN { use_ok 'SimpleLinks::Web' } +# use lib 'extlib'; +# use lib 't/lib'; + +BEGIN { + use_ok 'SimpleLinks'; +} + +diag( "Testing SimpleLinks $SimpleLinks::VERSION" ); diff --git a/t/00_startup/10_create_database.t b/t/00_startup/10_create_database.t index 3a7a6d6..0667e92 100644 --- a/t/00_startup/10_create_database.t +++ b/t/00_startup/10_create_database.t @@ -22,6 +22,7 @@ diag sprintf 'create database (%s)', my $model = $links->model; isa_ok($model, $Model_Class); + done_testing(); 1; diff --git a/t/10_model/00_category/10_edit.t b/t/10_model/00_category/10_edit.t deleted file mode 100644 index 3db6dbe..0000000 --- a/t/10_model/00_category/10_edit.t +++ /dev/null @@ -1,79 +0,0 @@ -use strict; -use warnings; -use local::lib; - -use Module::Load; -use Test::Exception; -use Test::More 0.87_01; -use Time::HiRes qw(time); - -use lib 't/lib'; -use lib 'extlib'; - -use SimpleLinks::Test::Constant; - -load $Service_Class; - -my $links = $Service_Class->new($Builder_Option_Of_Database); - -my ($category_a, $category_b); -{ - # insert categories - $category_a = $links->add_category({ - name => 'name_a' . time, - slug => 'slug_a' . time, - }); - $category_b = $links->add_category({ - name => 'name_b' . time, - slug => 'slug_b' . time, - }); -} - -{ - # same name - $category_a->name($category_b->name); - throws_ok { - $category_a->update; - } qr{column taxonomy_name is not unique}, - 'same name exception ok'; -} - -{ - # same slug - $category_a->slug($category_b->slug); - throws_ok { - $category_a->update; - } qr{column taxonomy_slug is not unique}, - 'same slug exception ok'; -} - -{ - # same name but differed parent - my $new_category = $links->add_category({ - name => 'name' . time, - slug => 'slug' . time, - parent => $category_a, - }); - $new_category->name($category_b->name); - lives_ok { - $new_category->update; - } 'same name but differed parent ok'; -} - -{ - # same slug but differed parent - my $new_category = $links->add_category({ - name => 'name' . time, - slug => 'slug' . time, - parent => $category_a, - }); - $new_category->slug($category_b->slug); - lives_ok { - $new_category->update; - } 'same slug but differed parent ok'; -} - -done_testing(); - -1; -__END__ diff --git a/t/10_model/00_category/00_insert.t b/t/10_service/00_category/00_create.t similarity index 79% rename from t/10_model/00_category/00_insert.t rename to t/10_service/00_category/00_create.t index 0576062..5be5ff9 100644 --- a/t/10_model/00_category/00_insert.t +++ b/t/10_service/00_category/00_create.t @@ -7,11 +7,10 @@ use Test::Exception; use Test::More 0.87_01; use Time::HiRes qw(time); -use lib 't/lib'; use lib 'extlib'; +use lib 't/lib'; use SimpleLinks::Test::Constant; - load $Service_Class; my $links = $Service_Class->new($Builder_Option_Of_Database); @@ -30,7 +29,7 @@ my $slug = 'slug' . time; my $certain_category; { - # insert category + # create a new category $certain_category = $links->add_category({ name => $name, slug => $slug, @@ -39,19 +38,21 @@ my $certain_category; isa_ok( $certain_category, 'Data::Model::Row' ); isa_ok( $certain_category, $Model_Class . '::category' ); + # category was created (read categories) my @categories = $links->categories; my @all_categories = $links->all_categories; is( scalar @categories, 1, 'count 1 ok (scalar @categoreis)' ); is( scalar @all_categories, 1, 'count 1 ok (scalar @all_categoreis)' ); is( $links->count_categories, 1, 'count 1 ok (count_categories)' ); + # created category has same column-values as query is( $categories[0]->id, $certain_category->id, 'id ok' ); is( $categories[0]->name, $name, 'name ok' ); is( $categories[0]->slug, $slug, 'slug ok' ); } { - # same name + # exception: same name as existent category my $new_category; throws_ok { $new_category = $links->add_category({ @@ -59,12 +60,12 @@ my $certain_category; slug => 'slug' . time, }); } qr{column taxonomy_name is not unique}, - 'same name exception ok'; - # ok( ! $new_category, 'same name not ok' ); + 'same name exception throwed'; + # ok( ! $new_category, 'same name not ok' ); # unnecessary (self-evident) } { - # same slug + # exception: same slug as existent category my $new_category; throws_ok { $new_category = $links->add_category({ @@ -72,8 +73,8 @@ my $certain_category; slug => $slug, }); } qr{column taxonomy_slug is not unique}, - 'same slug exception ok'; - # ok( ! $new_category, 'same slug not ok' ); + 'same slug exception throwed'; + # ok( ! $new_category, 'same slug not ok' ); # unnecessary (self-evident) } { @@ -83,7 +84,7 @@ my $certain_category; slug => 'slug' . time, parent => $certain_category, }); - ok( $new_category, 'same name but differed parent ok' ); + ok( $new_category, 'create same name but differed parent ok' ); } { @@ -93,9 +94,10 @@ my $certain_category; slug => $slug, parent => $certain_category, }); - ok( $new_category, 'same slug but differed parent ok' ); + ok( $new_category, 'create same slug but differed parent ok' ); } + done_testing(); 1; diff --git a/t/10_model/00_category/02_might_have_parent_at_insert.t b/t/10_service/00_category/02_might_have_parent_at_create.t similarity index 97% rename from t/10_model/00_category/02_might_have_parent_at_insert.t rename to t/10_service/00_category/02_might_have_parent_at_create.t index 1f2a58c..ae0fb82 100644 --- a/t/10_model/00_category/02_might_have_parent_at_insert.t +++ b/t/10_service/00_category/02_might_have_parent_at_create.t @@ -7,16 +7,15 @@ use Module::Load; use Test::More 0.87_01; use Time::HiRes qw(time); -use lib 't/lib'; use lib 'extlib'; +use lib 't/lib'; use SimpleLinks::Test::Constant; - load $Service_Class; my $links = $Service_Class->new($Builder_Option_Of_Database); -# insert categories these may have parent/children +# create new categories these may have parent/children my $category_a = $links->add_category({ name => 'name_a' . time, slug => 'slug_a' . time, @@ -54,7 +53,8 @@ my $category_g = $links->add_category({ }); ok( $category_g, 'create category has ancestor ok (g -> f -> e)' ); -# reload categories to get updated cache +# reload categories to update 'count' cache +# notice: must use alias (foreach $_) instead of copy (foreach my $category) foreach (( $category_a, $category_b, $category_c, $category_d, $category_e, $category_f, $category_g )) { $_ = $links->lookup(category => $_->id); diff --git a/t/10_service/00_category/10_read.t b/t/10_service/00_category/10_read.t new file mode 100644 index 0000000..8e2103d --- /dev/null +++ b/t/10_service/00_category/10_read.t @@ -0,0 +1,24 @@ +use strict; +use warnings; +use local::lib; + +use Module::Load; +use Test::Exception; +use Test::More 0.87_01; +use Time::HiRes qw(time); + +use lib 'extlib'; +use lib 't/lib'; + +use SimpleLinks::Test::Constant; +load $Service_Class; + +my $links = $Service_Class->new($Builder_Option_Of_Database); + +ok(1, 'dummy'); + + +done_testing(); + +1; +__END__ diff --git a/t/10_service/00_category/20_update.t b/t/10_service/00_category/20_update.t new file mode 100644 index 0000000..ea1d51a --- /dev/null +++ b/t/10_service/00_category/20_update.t @@ -0,0 +1,116 @@ +use strict; +use warnings; +use local::lib; + +use Module::Load; +use Test::Exception; +use Test::More 0.87_01; +use Time::HiRes qw(time); + +use lib 'extlib'; +use lib 't/lib'; + +use SimpleLinks::Test::Constant; +load $Service_Class; + +my $links = $Service_Class->new($Builder_Option_Of_Database); + +# create a certain category for target of comparison +my $name = 'name' . time; +my $slug = 'slug' . time; +my $certain_category = $links->add_category({ + name => $name, + slug => $slug, +}); + +{ + # create a new category for comparison + my $old_name = 'old_name' . time; + my $new_name = 'new_name' . time; + my $old_slug = 'old_slug' . time; + my $new_slug = 'new_slug' . time; + my $new_category = $links->add_category({ + name => $old_name, + slug => $old_slug, + }); + my $count_categories = $links->count_categories; + + # update existent category + $new_category->name($new_name); + $new_category->slug($new_slug); + lives_ok { + $new_category->update; + } 'edit name, slug & update ok'; + ok( $new_category, 'edit category ok' ); + isa_ok( $new_category, 'Data::Model::Row' ); + isa_ok( $new_category, $Model_Class . '::category' ); + + # category was updated + my @categories = $links->categories; # order by id + is( $links->count_categories, $count_categories, 'count not changed' ); + + # updated category has same column-values as query of update + my $updated_category = $categories[-1]; # last id + # my $updated_category = $links->lookup(category => $new_category->id); + is( $updated_category->id, $new_category->id, 'id not changed' ); + is( $updated_category->name, $new_name, 'name changed' ); + is( $updated_category->slug, $new_slug, 'slug changed' ); +} + +{ + # exception: same name as existent category + my $new_category = $links->add_category({ + name => 'name' . time, + slug => 'slug' . time, + }); + $new_category->name($name); + throws_ok { + $new_category->update; + } qr{column taxonomy_name is not unique}, + 'same name exception throwed'; +} + +{ + # exception: same slug as existent category + my $new_category = $links->add_category({ + name => 'name' . time, + slug => 'slug' . time, + }); + $new_category->slug($slug); + throws_ok { + $new_category->update; + } qr{column taxonomy_slug is not unique}, + 'same slug exception throwed'; +} + +{ + # same name but differed parent + my $new_category = $links->add_category({ + name => 'name' . time, + slug => 'slug' . time, + parent => $certain_category, + }); + $new_category->name($name); + lives_ok { + $new_category->update; + } 'edit same name but differed parent ok'; +} + +{ + # same slug but differed parent + my $new_category = $links->add_category({ + name => 'name' . time, + slug => 'slug' . time, + parent => $certain_category, + }); + $new_category->slug($slug); + lives_ok { + $new_category->update; + } 'edit same slug but differed parent ok'; +} + + +done_testing(); + +1; +__END__ diff --git a/t/10_service/00_category/30_delete.t b/t/10_service/00_category/30_delete.t new file mode 100644 index 0000000..8e2103d --- /dev/null +++ b/t/10_service/00_category/30_delete.t @@ -0,0 +1,24 @@ +use strict; +use warnings; +use local::lib; + +use Module::Load; +use Test::Exception; +use Test::More 0.87_01; +use Time::HiRes qw(time); + +use lib 'extlib'; +use lib 't/lib'; + +use SimpleLinks::Test::Constant; +load $Service_Class; + +my $links = $Service_Class->new($Builder_Option_Of_Database); + +ok(1, 'dummy'); + + +done_testing(); + +1; +__END__ diff --git a/t/10_model/01_tag/00_insert.t b/t/10_service/01_tag/00_create.t similarity index 80% rename from t/10_model/01_tag/00_insert.t rename to t/10_service/01_tag/00_create.t index 264f436..ae18ef8 100644 --- a/t/10_model/01_tag/00_insert.t +++ b/t/10_service/01_tag/00_create.t @@ -7,11 +7,10 @@ use Test::Exception; use Test::More 0.87_01; use Time::HiRes qw(time); -use lib 't/lib'; use lib 'extlib'; +use lib 't/lib'; use SimpleLinks::Test::Constant; - load $Service_Class; my $links = $Service_Class->new($Builder_Option_Of_Database); @@ -29,7 +28,7 @@ my $name = 'name' . time; my $slug = 'slug' . time; { - # insert tag + # create a new tag my $new_tag = $links->add_tag({ name => $name, slug => $slug, @@ -38,19 +37,21 @@ my $slug = 'slug' . time; isa_ok( $new_tag, 'Data::Model::Row' ); isa_ok( $new_tag, $Model_Class . '::tag' ); + # tag was created (read tags) my @tags = $links->tags; my @all_tags = $links->all_tags; is( scalar @tags, 1, 'count 1 ok (scalar @tags)' ); is( scalar @all_tags, 1, 'count 1 ok (scalar @all_tags)' ); is( $links->count_tags, 1, 'count 1 ok (count_tags)' ); + # created tag has same column-values as query is( $tags[0]->id, $new_tag->id, 'id ok' ); is( $tags[0]->name, $name, 'name ok' ); is( $tags[0]->slug, $slug, 'slug ok' ); } { - # same name + # exception: same name as existent tag my $new_tag; throws_ok { $new_tag = $links->add_tag({ @@ -58,12 +59,12 @@ my $slug = 'slug' . time; slug => 'slug' . time, }); } qr{column taxonomy_name is not unique}, - 'same name exception ok'; - # ok( ! $new_tag, 'same name not ok' ); + 'same name exception throwed'; + # ok( ! $new_tag, 'same name not ok' ); # unnecessary (self-evident) } { - # same slug + # exception: same slug as existent tag my $new_tag; throws_ok { $new_tag = $links->add_tag({ @@ -71,10 +72,11 @@ my $slug = 'slug' . time; slug => $slug, }); } qr{column taxonomy_slug is not unique}, - 'same slug exception ok'; - # ok( ! $new_tag, 'same slug not ok' ); + 'same slug exception throwed'; + # ok( ! $new_tag, 'same slug not ok' ); # unnecessary (self-evident) } + done_testing(); 1; diff --git a/t/10_model/02_website/00_insert.t b/t/10_service/02_website/00_create.t similarity index 91% rename from t/10_model/02_website/00_insert.t rename to t/10_service/02_website/00_create.t index e72c098..949dda1 100644 --- a/t/10_model/02_website/00_insert.t +++ b/t/10_service/02_website/00_create.t @@ -5,11 +5,10 @@ use local::lib; use Module::Load; use Test::More 0.87_01; -use lib 't/lib'; use lib 'extlib'; +use lib 't/lib'; use SimpleLinks::Test::Constant; - load $Service_Class; my $links = $Service_Class->new($Builder_Option_Of_Database); @@ -24,10 +23,9 @@ my $links = $Service_Class->new($Builder_Option_Of_Database); } { - # insert website + # create a new website my $title = 'foobar'; my $uri = 'http://foobar.example/'; - my $new_website = $links->add_website({ title => $title, uri => $uri, @@ -36,16 +34,19 @@ my $links = $Service_Class->new($Builder_Option_Of_Database); isa_ok( $new_website, 'Data::Model::Row' ); isa_ok( $new_website, $Model_Class . '::website' ); + # website was created (read websites) my @websites = $links->websites; my @all_websites = $links->all_websites; is( scalar @websites, 1, 'count 1 ok (scalar @websites)' ); is( scalar @all_websites, 1, 'count 1 ok (scalar @all_websites)' ); is( $links->count_websites, 1, 'count 1 ok (count_websites)' ); + # created website has same column-values as query is( $websites[0]->title, $title, 'tile ok' ); is( $websites[0]->uri, $uri, 'uri ok' ); } + done_testing(); 1; diff --git a/t/20_model/00_compile.t b/t/20_model/00_compile.t new file mode 100644 index 0000000..fb5401c --- /dev/null +++ b/t/20_model/00_compile.t @@ -0,0 +1,19 @@ +#!perl -T + +# use strict; +# use warnings; +use local::lib; + +use Test::More tests => 1; + +# use lib 'extlib'; +# use lib 't/lib'; + +# dummy +ok(1, 'dummy'); + + +done_testing(); + +1; +__END__ diff --git a/t/20_controller/00_index.t b/t/30_controller/00_index.t similarity index 100% rename from t/20_controller/00_index.t rename to t/30_controller/00_index.t index caa6bc3..99668aa 100644 --- a/t/20_controller/00_index.t +++ b/t/30_controller/00_index.t @@ -5,8 +5,8 @@ use local::lib; use Module::Load; use Test::More 0.87_01; -use lib 't/lib'; use lib 'extlib'; +use lib 't/lib'; use SimpleLinks::Test::Constant; diff --git a/t/40_view/00_compile.t b/t/40_view/00_compile.t new file mode 100644 index 0000000..7ca436f --- /dev/null +++ b/t/40_view/00_compile.t @@ -0,0 +1,36 @@ +# use strict; +# use warnings; +use local::lib; + +use Test::More 0.87_01; + +use lib 'extlib'; +# use lib 't/lib'; + +use SimpleLinks::Web; + +use Ark::Test 'SimpleLinks::Web', components => [qw( + Model::Links + View::MT + Controller::Root +)]; + +SKIP: { + skip 'because I know no process testing Ark application', 2; + +{ + my $content = get('/'); + is( $content, 'index mt', 'index view ok' ); +} + +{ + my $content = get('/amazing/deep/path/you/may/not/think/it'); + is( $content, '404 mt', '404 view ok' ); +} + +}; + +done_testing(); + +1; +__END__ diff --git a/t/50_feed/00_compile.t b/t/50_feed/00_compile.t new file mode 100644 index 0000000..fb5401c --- /dev/null +++ b/t/50_feed/00_compile.t @@ -0,0 +1,19 @@ +#!perl -T + +# use strict; +# use warnings; +use local::lib; + +use Test::More tests => 1; + +# use lib 'extlib'; +# use lib 't/lib'; + +# dummy +ok(1, 'dummy'); + + +done_testing(); + +1; +__END__ diff --git a/t/60_web_api/00_compile.t b/t/60_web_api/00_compile.t new file mode 100644 index 0000000..fb5401c --- /dev/null +++ b/t/60_web_api/00_compile.t @@ -0,0 +1,19 @@ +#!perl -T + +# use strict; +# use warnings; +use local::lib; + +use Test::More tests => 1; + +# use lib 'extlib'; +# use lib 't/lib'; + +# dummy +ok(1, 'dummy'); + + +done_testing(); + +1; +__END__ diff --git a/t/70_command/00_compile.t b/t/70_command/00_compile.t new file mode 100644 index 0000000..fb5401c --- /dev/null +++ b/t/70_command/00_compile.t @@ -0,0 +1,19 @@ +#!perl -T + +# use strict; +# use warnings; +use local::lib; + +use Test::More tests => 1; + +# use lib 'extlib'; +# use lib 't/lib'; + +# dummy +ok(1, 'dummy'); + + +done_testing(); + +1; +__END__ diff --git a/t/80_batch/00_compile.t b/t/80_batch/00_compile.t new file mode 100644 index 0000000..fb5401c --- /dev/null +++ b/t/80_batch/00_compile.t @@ -0,0 +1,19 @@ +#!perl -T + +# use strict; +# use warnings; +use local::lib; + +use Test::More tests => 1; + +# use lib 'extlib'; +# use lib 't/lib'; + +# dummy +ok(1, 'dummy'); + + +done_testing(); + +1; +__END__ diff --git a/t/90_cleanup/00_unlink_database.t b/t/90_cleanup/00_unlink_database.t index 79591d1..f6a0161 100644 --- a/t/90_cleanup/00_unlink_database.t +++ b/t/90_cleanup/00_unlink_database.t @@ -2,8 +2,6 @@ use strict; use warnings; use local::lib; -# use Cwd qw(cwd); -# use File::Spec qw(); use Test::More 0.87_01; use lib 'extlib'; @@ -21,8 +19,8 @@ END { eval { cleanup(); }; - # Because "Permission denied" error may happen on Win32, - # I don't ok(! -f $Database_Name, 'database file was unlinked'); + # Because "Permission denied" error may happen on Win32, I don't this test: + # ok(! -f $Database_Name, 'database file was unlinked'); } 1; diff --git a/t/lib/SimpleLinks/Test/Cleanup.pm b/t/lib/SimpleLinks/Test/Cleanup.pm index 895e524..e70f6ed 100644 --- a/t/lib/SimpleLinks/Test/Cleanup.pm +++ b/t/lib/SimpleLinks/Test/Cleanup.pm @@ -1,16 +1,41 @@ package SimpleLinks::Test::Cleanup; + +# **************************************************************** +# pragmas +# **************************************************************** + use strict; use warnings; + +# **************************************************************** +# superclasses +# **************************************************************** + use base qw( Exporter ); + +# **************************************************************** +# general dependencies +# **************************************************************** + use English; + +# **************************************************************** +# internal dependencies +# **************************************************************** + use SimpleLinks::Test::Constant; + +# **************************************************************** +# class variables : Exporter settings +# **************************************************************** + our @EXPORT = qw( cleanup ); @@ -19,6 +44,11 @@ our @EXPORT_OK = qw( our %EXPORT_TAGS = ( ); + +# **************************************************************** +# functions +# **************************************************************** + sub cleanup { unlink $Database_Name or warn sprintf 'Cannot unlink database (%s) by (UID:%s) because: %s', @@ -27,9 +57,19 @@ sub cleanup { $OS_ERROR; } + +# **************************************************************** +# return true +# **************************************************************** + 1; __END__ + +# **************************************************************** +# POD +# **************************************************************** + =head1 NAME SimpleLinks::Test::Cleanup - cleanup environment when end of SimpleLinks test @@ -62,7 +102,7 @@ L =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/t/lib/SimpleLinks/Test/Constant.pm b/t/lib/SimpleLinks/Test/Constant.pm index 5c3caab..cbec288 100644 --- a/t/lib/SimpleLinks/Test/Constant.pm +++ b/t/lib/SimpleLinks/Test/Constant.pm @@ -1,15 +1,35 @@ package SimpleLinks::Test::Constant; + +# **************************************************************** +# pragmas +# **************************************************************** + use strict; use warnings; -# use Env qw(__SimpleLinks_Test_Database_Name); -# use File::Temp qw(); + +# **************************************************************** +# superclasses +# **************************************************************** use base qw( Exporter ); + +# **************************************************************** +# general dependencies +# **************************************************************** + +# use Env qw(__SimpleLinks_Test_Database_Name); +# use File::Temp qw(); + + +# **************************************************************** +# class variables : Exporter settings +# **************************************************************** + our @EXPORT = qw( $Service_Class $Schema_Factory @@ -20,6 +40,11 @@ our @EXPORT_OK = qw( our %EXPORT_TAGS = ( ); + +# **************************************************************** +# class variables +# **************************************************************** + our $Service_Class = 'SimpleLinks::Service::Links'; our $Schema_Factory = 'Faktro::Schema::Factory'; @@ -28,6 +53,7 @@ our $DBMS = 'SQLite'; our $Model_Class = 'SimpleLinks::Schema::Table'; +our $Database_Name = 'test_database.tmp'; # Cannot unlink test database on Win32 environment. # Also cannnot unlink test dtabase created by File::Temp, on Win32 environment. # Because test guarantee that filename of test dabase differ with time. @@ -39,7 +65,6 @@ our $Model_Class = 'SimpleLinks::Schema::Table'; # )->filename; # $__SimpleLinks_Test_Database_Name = $Database_Name; # } -our $Database_Name = 'test_database.tmp'; our $Builder_Option_Of_Database = { schema_factory => $Schema_Factory, @@ -52,9 +77,19 @@ our $Builder_Option_Of_Database = { }, }; + +# **************************************************************** +# return true +# **************************************************************** + 1; __END__ + +# **************************************************************** +# POD +# **************************************************************** + =head1 NAME SimpleLinks::Test::Constant - export constants for test of SimpleLinks @@ -78,7 +113,7 @@ L =back -=head1 LICENCE AND COPYRIGHT +=head1 LICENSE AND COPYRIGHT Copyright (c) 2009 by MORIYA Masaki ("Gardejo"), L. diff --git a/xt/no_tabs.t b/xt/no_tabs.t new file mode 100644 index 0000000..8e7233f --- /dev/null +++ b/xt/no_tabs.t @@ -0,0 +1,18 @@ +#!perl -T + +use FindBin; + +eval { + use Test::NoTabs; +}; + +Test::More::plan( skip_all => + "Test::NoTabs required " . + "for testing presence of tabs" +) if $@; + +# inc/ModuleInstall/* will die. +# all_perl_files_ok(); + +# WTF? cannnot read. +all_perl_files_ok("$FindBin::Bin/../lib"); diff --git a/xt/perlcritic.t b/xt/perlcritic.t new file mode 100644 index 0000000..ec8285e --- /dev/null +++ b/xt/perlcritic.t @@ -0,0 +1,18 @@ +#!perl -T + +eval { + use Perl::Critic 1.094; # for equivalent_modules + use Test::Perl::Critic; +}; + +Test::More::plan( skip_all => + "Perl::Critic 1.094 and Test::Perl::Critic required " . + "for testing PBP compliance" +) if $@; + +# 'use Any::Moose' and 'use Ark' are same as 'use strict' and 'use warnings' +Test::Perl::Critic->import( + -profile => 'xt/perlcriticrc', +); + +Test::Perl::Critic::all_critic_ok(); diff --git a/xt/perlcriticrc b/xt/perlcriticrc new file mode 100644 index 0000000..c3fc006 --- /dev/null +++ b/xt/perlcriticrc @@ -0,0 +1,5 @@ +[TestingAndDebugging::RequireUseStrict] +equivalent_modules = Any::Moose Ark + +[TestingAndDebugging::RequireUseWarnings] +equivalent_modules = Any::Moose Ark diff --git a/xt/pod.t b/xt/pod.t new file mode 100644 index 0000000..beeee0e --- /dev/null +++ b/xt/pod.t @@ -0,0 +1,12 @@ +#!perl -T + +eval { + use Test::Pod 1.40; +}; + +Test::More::plan( skip_all => + "Test::Pod 1.40 required " . + "for testing POD" +) if $@; + +all_pod_files_ok(); diff --git a/xt/pod_coverage.t b/xt/pod_coverage.t new file mode 100644 index 0000000..a8571f9 --- /dev/null +++ b/xt/pod_coverage.t @@ -0,0 +1,15 @@ +#!perl -T + +eval { + use Test::Pod::Coverage 1.08; +}; + +Test::More::plan( skip_all => + "Test::Pod::Coverage 1.08 required " . + "for testing POD coverage" +) if $@; + +all_pod_coverage_ok('lib'); + +# note: Devel::Cover and Attribute::Protected and Test::Pod::Coverage +# are incompatible? diff --git a/xt/synopsis.t b/xt/synopsis.t new file mode 100644 index 0000000..2fb2992 --- /dev/null +++ b/xt/synopsis.t @@ -0,0 +1,12 @@ +#!perl -T + +eval { + use Test::Synopsis 0.06; +}; + +Test::More::plan( skip_all => + "Test::Synopsis 0.06 required " . + "for testing POD synopsis" +) if $@; + +all_synopsis_ok('lib'); diff --git a/xt/use_all_modules.t b/xt/use_all_modules.t new file mode 100644 index 0000000..8483c64 --- /dev/null +++ b/xt/use_all_modules.t @@ -0,0 +1,14 @@ +#!perl -T + +eval { + use Test::UseAllModules; +}; + +Test::More::plan( skip_all => + "Test::UseAllModules required " . + "for testing presence of all manifested modules" +) if $@; + +BEGIN { + all_uses_ok(); +}