FormValidator-Simple-0.29/000755 000765 000024 00000000000 11670057572 016303 5ustar00lyokatostaff000000 000000 FormValidator-Simple-0.29/Changes000644 000765 000024 00000007164 11670056631 017601 0ustar00lyokatostaff000000 000000 Revision history for Perl extension FormValidator::Simple. 0.29 Thu Dec 08 15:45:00 2011 - better BETWEEN check: allow float decimal https://github.com/lyokato/p5-formvalidator-simple/pull/1 0.28 Mon Jun 22 14:30:00 2009 - bugfix: on single apache process, 'each' command in Profile.pm breaks hash reference. Thanks to asannou. 0.23 Thr Apr 17 21:17:00 2008 - Applied a patch which lets FVS loads plugin easily with +, like Catalyst. Thanks to Jiro Nishiguchi. 0.22 Tue Mar 6 20:07:00 2007 - Applied a patch that lets it work as expected in case *set_messages* is invoked after *check*. Thanks to Yappo. 0.21 Wed Feb 2 17:52:00 2007 - Applied a patch and set_messages_decode_from method was implemented. Thanks to Yasuhiro Horiuchi. 0.20 Wed Jan 24 20:05:00 2007 - Added field_messages method on Results class. required by Jim Spath, Thanks. 0.19 Thu Oct 26 18:52:00 2006 - Added set_invalid method to Results class. This function is described in POD, but didn't work. Applied a patche from IKEBE Tomohiro. Thanks! 0.18 Tue Sep 12 18:20:00 2006 - bugfix: numeric comperison, GREATER_THAN, LESS_THAN, and EQUAL_TO doesn't work as expected when 0 is passed as arguments. Thanks to Ryo Okamoto. 0.17 Tue Sep 05 15:22:00 2006 - took CLACO's patch that resolves RT issues: 21224, 20658, 19667. RT20658: fixed POD error, thanks to ISHIGAKI. RT20658: fixed Profile _init from eating profile via slice set_messages on object now overrides messages set on class RT21224: added 'clear' method to FVS::Results. Thanks to CLACO. 0.16 Tue May 16 10:19:00 2006 - added DATETIME_FORMAT and DATETIME_STRPTIME validation Thanks to Masahiro Nagano and fbis. new sample for IN_ARRAY on POD bugfix: IN_ARRAY didn't work well with numeric arguments. Thanks to ISLUE 0.15 Mon Apr 24 11:51:00 2006 - added IN_ARRAY validation Thanks to Masahiro Nagano. - bugfix: fixed to use Scalar::Util::blessed instead of UNIVERSAL::isa because of its unexpected work on perl 5.8.0. Thanks to Toru Yamaguchi allow to handle 0 on 'BETWEEN' validation Thanks to Masahiro Nagano. 0.14 Mon Mar 13 03:19:00 2006 - added UINT validation Thanks to Tokuhirom. 0.13 Thu Nov 24 00:45:00 2005 - added set_message_format Thanks to Daisuke Murase. 0.12 Thu Nov 24 00:45:00 2005 - added validation ALL 0.11 Thu Nov 24 00:45:00 2005 - added set_option method 0.10 Thu Nov 17 12:00:00 2005 - added error-message handler 0.09 Wed Nov 16 23:00:00 2005 - added documentation for FormValidation::Simple::Results 0.08 Tue Nov 15 21:00:00 2005 - added some methods to FormValidator::Simple::Results. changed behavior of validation DATE and DATETIME, now it returns string or DateTime object or Time::Piece one, you can choose it in option-setting. 0.07 Mon Oct 31 21:00:00 2005 - added validation DECIMAL 0.06 Thu Oct 27 21:00:00 2005 - added validations: numeric comparisons GREATER_THAN LESS_THAN EQUAL_TO BETWEEN ( suggested by Jody Alkema ) 0.05 Thu Oct 20 01:00:00 2005 - added validation HTTP_URL 0.04 Wed Oct 19 20:00:00 2005 - added validation SELECTED_AT_LEAST fixed some code didn't work as expected. 0.03 Sun Oct 1 22:00:00 2005 - little bit fixed documentation and Makefile.PL 0.02 Sun Sep 25 22:00:00 2005 - cpan release version 0.01 Thu Sep 1 10:38:22 2005 - original version; created by h2xs 1.23 with options -X -A FormValidator::Simple FormValidator-Simple-0.29/inc/000755 000765 000024 00000000000 11670057572 017054 5ustar00lyokatostaff000000 000000 FormValidator-Simple-0.29/lib/000755 000765 000024 00000000000 11670057572 017051 5ustar00lyokatostaff000000 000000 FormValidator-Simple-0.29/Makefile.PL000644 000765 000024 00000001412 11670056435 020250 0ustar00lyokatostaff000000 000000 use inc::Module::Install; name 'FormValidator-Simple'; all_from 'lib/FormValidator/Simple.pm'; requires 'Class::Accessor' => 0.22; requires 'Class::Inspector' => 1.13; requires 'Class::Data::Inheritable' => 0.04; requires 'Class::Data::Accessor' => 0.03; requires 'UNIVERSAL::require' => 0.10; requires 'Mail::Address' => 0; requires 'Email::Valid' => 0.15; requires 'Email::Valid::Loose' => 0.04; requires 'Date::Calc' => 5.4; requires 'Tie::IxHash' => 1.21; requires 'YAML' => 0.39; requires 'List::MoreUtils' => 0.16; requires 'Scalar::Util' => 0; requires 'DateTime::Format::Strptime' => 1.0700; auto_install; WriteAll; FormValidator-Simple-0.29/MANIFEST000644 000765 000024 00000002560 11670057517 017436 0ustar00lyokatostaff000000 000000 Changes 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/Win32.pm inc/Module/Install/WriteAll.pm lib/FormValidator/Simple.pm lib/FormValidator/Simple/ArrayList.pm lib/FormValidator/Simple/Constants.pm lib/FormValidator/Simple/Constraint.pm lib/FormValidator/Simple/Constraints.pm lib/FormValidator/Simple/Data.pm lib/FormValidator/Simple/Exception.pm lib/FormValidator/Simple/Iterator.pm lib/FormValidator/Simple/Messages.pm lib/FormValidator/Simple/Profile.pm lib/FormValidator/Simple/Result.pm lib/FormValidator/Simple/Results.pm lib/FormValidator/Simple/Validator.pm Makefile.PL MANIFEST MANIFEST.SKIP META.yml README t/00_compile.t t/01_constraint.t t/02_constraints.t t/03_profile.t t/04_result.t t/05_results.t t/06_data.t t/07_simple.t t/08_length.t t/09_ascii.t t/10_int.t t/11_space.t t/12_duplication.t t/13_datetime.t t/14_regex.t t/15_any.t t/16_plugin.t t/17_pod.t t/18_invalids.t t/19_url.t t/20_numeric_cmp.t t/21_decimal.t t/22_messages.t t/23_messages_yaml.t t/24_options.t t/25_all.t t/26_inarray.t t/27_set_invalid.t t/28_decode.t t/conf/messages.yml t/conf/messages_ja.yml t/lib/FormValidator/Simple/Plugin/Sample.pm t/lib/MyNamespace/MyPlugin.pm FormValidator-Simple-0.29/MANIFEST.SKIP000644 000765 000024 00000000173 11670056435 020177 0ustar00lyokatostaff000000 000000 \bRCS\b \bCVS\b ^MANIFEST\. ^Makefile$ ~$ \.old$ ^blib/ ^pm_to_blib ^MakeMaker-\d \.gz$ \.cvsignore ^9\d_.*\.t \.svn \.git FormValidator-Simple-0.29/META.yml000644 000765 000024 00000001522 11670057572 017554 0ustar00lyokatostaff000000 000000 --- abstract: 'validation with simple chains of constraints ' author: - 'Lyo Kato ' build_requires: ExtUtils::MakeMaker: 6.42 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 1.00' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: FormValidator-Simple no_index: directory: - inc - t requires: Class::Accessor: 0.22 Class::Data::Accessor: 0.03 Class::Data::Inheritable: 0.04 Class::Inspector: 1.13 Date::Calc: 5.4 DateTime::Format::Strptime: 1.07 Email::Valid: 0.15 Email::Valid::Loose: 0.04 List::MoreUtils: 0.16 Mail::Address: 0 Scalar::Util: 0 Tie::IxHash: 1.21 UNIVERSAL::require: 0.1 YAML: 0.39 resources: license: http://dev.perl.org/licenses/ version: 0.29 FormValidator-Simple-0.29/README000644 000765 000024 00000033260 11670056435 017164 0ustar00lyokatostaff000000 000000 NAME FormValidator::Simple - validation with simple chains of constraints SYNOPSIS my $query = CGI->new; $query->param( param1 => 'ABCD' ); $query->param( param2 => 12345 ); $query->param( mail1 => 'lyo.kato@gmail.com' ); $query->param( mail2 => 'lyo.kato@gmail.com' ); $query->param( year => 2005 ); $query->param( month => 11 ); $query->param( day => 27 ); my $result = FormValidator::Simple->check( $query => [ param1 => ['NOT_BLANK', 'ASCII', ['LENGTH', 2, 5]], param2 => ['NOT_BLANK', 'INT' ], mail1 => ['NOT_BLANK', 'EMAIL_LOOSE'], mail2 => ['NOT_BLANK', 'EMAIL_LOOSE'], { mails => ['mail1', 'mail2' ] } => ['DUPLICATION'], { date => ['year', 'month', 'day'] } => ['DATE'], ] ); if ( $result->has_error ) { my $tt = Template->new({ INCLUDE_PATH => './tmpl' }); $tt->process('template.html', { result => $result }); } template example [% IF result.has_error %]

Found Input Error

[% END %] example2 [% IF result.has_error %] [% END %] DESCRIPTION This module provides you a sweet way of form data validation with simple constraints chains. You can write constraints on single line for each input data. This idea is based on Sledge::Plugin::Validator, and most of validation code is borrowed from this plugin. (Sledge is a MVC web application framework: http://sl.edge.jp [Japanese] ) The result object this module returns behaves like Data::FormValidator::Results. HOW TO SET PROFILE FormValidator::Simple->check( $q => [ #profile ] ); Use 'check' method. A hash reference includes input data, or an object of some class that has a method named 'param', for example CGI, is needed as first argument. And set profile as array reference into second argument. Profile consists of some pairs of input data and constraints. my $q = CGI->new; $q->param( param1 => 'hoge' ); FormValidator::Simple->check( $q => [ param1 => [ ['NOT_BLANK'], ['LENGTH', 4, 10] ], ] ); In this case, param1 is the name of a form element. and the array ref "[ ['NOT_BLANK']... ]" is a constraints chain. Write constraints chain as arrayref, and you can set some constraints into it. In the last example, two constraints 'NOT_BLANK', and 'LENGTH' are set. Each constraints is should be set as arrayref, but in case the constraint has no argument, it can be written as scalar text. FormValidator::Simple->check( $q => [ param1 => [ 'NOT_BLANK', ['LENGTH', 4, 10] ], ] ); Now, in this sample 'NOT_BLANK' constraint is not an arrayref, but 'LENGTH' isn't. Because 'LENGTH' has two arguments, 4 and 10. MULTIPLE DATA VALIDATION When you want to check about multiple input data, do like this. my $q = CGI->new; $q->param( mail1 => 'lyo.kato@gmail.com' ); $q->param( mail2 => 'lyo.kato@gmail.com' ); my $result = FormValidator::Simple->check( $q => [ { mails => ['mail1', 'mail2'] } => [ 'DUPLICATION' ], ] ) [% IF result.invalid('mails') %]

mail1 and mail2 aren't same.

[% END %] and here's an another example. my $q = CGI->new; $q->param( year => 2005 ); $q->param( month => 12 ); $q->param( day => 27 ); my $result = FormValidator::Simple->check( $q => [ { date => ['year', 'month', 'day'] } => [ 'DATE' ], ] ); [% IF result.invalid('date') %]

Set correct date.

[% END %] FLEXIBLE VALIDATION my $valid = FormValidator::Simple->new(); $valid->check( $q => [ param1 => [qw/NOT_BLANK ASCII/, [qw/LENGTH 4 10/] ], ] ); $valid->check( $q => [ param2 => [qw/NOT_BLANK/], ] ); my $results = $valid->results; if ( found some error... ) { $results->set_invalid('param3' => 'MY_ERROR'); } template example [% IF results.invalid('param1') %] ... [% END %] [% IF results.invalid('param2') %] ... [% END %] [% IF results.invalid('param3', 'MY_ERROR') %] ... [% END %] HOW TO SET OPTIONS Option setting is needed by some validation, especially in plugins. You can set them in two ways. FormValidator::Simple->set_option( dbic_base_class => 'MyProj::Model::DBIC', charset => 'euc', ); or $valid = FormValidator::Simple->new( dbic_base_class => 'MyProj::Model::DBIC', charset => 'euc', ); $valid->check(...) VALIDATION COMMANDS You can use follow variety validations. and each validations can be used as negative validation with 'NOT_' prefix. FormValidator::Simple->check( $q => [ param1 => [ 'INT', ['LENGTH', 4, 10] ], param2 => [ 'NOT_INT', ['NOT_LENGTH', 4, 10] ], ] ); SP check if the data has space or not. INT check if the data is integer or not. UINT unsigined integer check. for example, if -1234 is input, the validation judges it invalid. DECIMAL $q->param( 'num1' => '123.45678' ); my $result = FormValidator::Simple->check( $q => [ num1 => [ ['DECIMAL', 3, 5] ], ] ); each numbers (3,5) mean maximum digits before/after '.' ASCII check is the data consists of only ascii code. LENGTH check the length of the data. my $result = FormValidator::Simple->check( $q => [ param1 => [ ['LENGTH', 4] ], ] ); check if the length of the data is 4 or not. my $result = FormValidator::Simple->check( $q => [ param1 => [ ['LENGTH', 4, 10] ], ] ); when you set two arguments, it checks if the length of data is in the range between 4 and 10. HTTP_URL verify it is a http(s)-url my $result = FormValidator::Simple->check( $q => [ param1 => [ 'HTTP_URL' ], ] ); SELECTED_AT_LEAST verify the quantity of selected parameters is counted over allowed minimum. Music Movie Game my $result = FormValidator::Simple->check( $q => [ hobby => ['NOT_BLANK', ['SELECTED_AT_LEAST', 2] ], ] ); REGEX check with regular expression. my $result = FormValidator::Simple->check( $q => [ param1 => [ ['REGEX', qr/^hoge$/ ] ], ] ); DUPLICATION check if the two data are same or not. my $result = FormValidator::Simple->check( $q => [ { duplication_check => ['param1', 'param2'] } => [ 'DUPLICATION' ], ] ); EMAIL check with Email::Valid. EMAIL_MX check with Email::Valid, including mx check. EMAIL_LOOSE check with Email::Valid::Loose. EMAIL_LOOSE_MX check with Email::Valid::Loose, including mx check. DATE check with Date::Calc my $result = FormValidator::Simple->check( $q => [ { date => [qw/year month day/] } => [ 'DATE' ] ] ); TIME check with Date::Calc my $result = FormValidator::Simple->check( $q => [ { time => [qw/hour min sec/] } => ['TIME'], ] ); DATETIME check with Date::Calc my $result = FormValidator::Simple->check( $q => [ { datetime => [qw/year month day hour min sec/] } => ['DATETIME'] ] ); DATETIME_STRPTIME check with DateTime::Format::Strptime. my $q = CGI->new; $q->param( datetime => '2006-04-26T19:09:21+0900' ); my $result = FormValidator::Simple->check( $q => [ datetime => [ [ 'DATETIME_STRPTIME', '%Y-%m-%dT%T%z' ] ], ] ); DATETIME_FORMAT check with DateTime::Format::***. for example, DateTime::Format::HTTP, DateTime::Format::Mail, DateTime::Format::MySQL and etc. my $q = CGI->new; $q->param( datetime => '2004-04-26 19:09:21' ); my $result = FormValidator::Simple->check( $q => [ datetime => [ [qw/DATETIME_FORMAT MySQL/] ], ] ); GREATER_THAN numeric comparison my $result = FormValidator::Simple->check( $q => [ age => [ ['GREATER_THAN', 25] ], ] ); LESS_THAN numeric comparison my $result = FormValidator::Simple->check( $q => [ age => [ ['LESS_THAN', 25] ], ] ); EQUAL_TO numeric comparison my $result = FormValidator::Simple->check( $q => [ age => [ ['EQUAL_TO', 25] ], ] ); BETWEEN numeric comparison my $result = FormValidator::Simple->check( $q => [ age => [ ['BETWEEN', 20, 25] ], ] ); ANY check if there is not blank data in multiple data. my $result = FormValidator::Simple->check( $q => [ { some_data => [qw/param1 param2 param3/] } => ['ANY'] ] ); IN_ARRAY check if the food ordered is in menu my $result = FormValidator::Simple->check( $q => [ food => [ ['IN_ARRAY', qw/noodle soba spaghetti/] ], ] }; HOW TO LOAD PLUGINS use FormValidator::Simple qw/Japanese CreditCard/; FormValidator::Simple::Plugin::Japanese, FormValidator::Simple::Plugin::CreditCard are loaded. or use 'load_plugin' method. use FormValidator::Simple; FormValidator::Simple->load_plugin('FormValidator::Simple::Plugin::CreditCard'); MESSAGE HANDLING You can custom your own message with key and type. [% IF result.has_error %] [% FOREACH key IN result.error %] [% FOREACH type IN result.error(key) %]

error message:[% type %] - [% key %]

[% END %] [% END %] [% END %] And you can also set messages configuration before. You can prepare configuration as hash reference. FormValidator::Simple->set_messages( { action1 => { name => { NOT_BLANK => 'input name!', LENGTH => 'input name (length should be between 0 and 10)!', }, email => { DEFAULT => 'input correct email address!', }, }, } ); or a YAML file. # messages.yml DEFAULT: name: DEFAULT: name is invalid! action1: name: NOT_BLANK: input name! LENGTH: input name(length should be between 0 and 10)! email: DEFAULT: input correct email address! action2: name: DEFAULT: ... # in your perl-script, set the file's path. FormValidator::Simple->set_messages('messages.yml'); DEFAULT is a special type. If it can't find setting for indicated validation-type, it uses message set for DEFAULT. after setting, execute check(), my $result = FormValidator::Simple->check( $q => [ name => [qw/NOT_BLANK/, [qw/LENGTH 0 10/] ], email => [qw/NOT_BLANK EMAIL_LOOSE/, [qw/LENGTH 0 20/] ], ] ); # matching result and messages for indicated action. my $messages = $result->messages('action1'); foreach my $message ( @$messages ) { print $message, "\n"; } When it can't find indicated action, name, and type, it searches proper message from DEFAULT action. If in template file, [% IF result.has_error %] [% FOREACH msg IN result.messages('action1') %]

[% msg %]

[% END %] [% END %] you can set each message format. FormValidator::Simple->set_message_format('

%s

'); my $result = FormValidator::Simple->check( $q => [ ...profile ] ); [% IF result.has_error %] [% result.messages('action1').join("\n") %] [% END %] RESULT HANDLING See FormValidator::Simple::Results SEE ALSO Data::FormValidator http://sl.edge.jp/ (Japanese) http://sourceforge.jp/projects/sledge AUTHOR Lyo Kato COPYRIGHT AND LICENSE This library is free software. You can redistribute it and/or modify it under the same terms as perl itself. FormValidator-Simple-0.29/t/000755 000765 000024 00000000000 11670057572 016546 5ustar00lyokatostaff000000 000000 FormValidator-Simple-0.29/t/00_compile.t000644 000765 000024 00000000123 11670056435 020653 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 1; BEGIN{ use_ok("FormValidator::Simple") } FormValidator-Simple-0.29/t/01_constraint.t000644 000765 000024 00000002175 11670056435 021421 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 23; BEGIN{ use_ok("FormValidator::Simple::Constraint") } my $c1 = FormValidator::Simple::Constraint->new( ['NOT_BLANK'] ); is( $c1->name, 'NOT_BLANK' ); is( $c1->command, 'BLANK' ); ok( $c1->negative ); my $c2 = FormValidator::Simple::Constraint->new( 'NOT_BLANK' ); is( $c2->name, 'NOT_BLANK' ); is( $c2->command, 'BLANK' ); ok( $c2->negative ); my $c3 = FormValidator::Simple::Constraint->new( ['INT'] ); is( $c3->name, 'INT' ); is( $c3->command, 'INT' ); ok( !$c3->negative ); my $c4 = FormValidator::Simple::Constraint->new( 'ASCII' ); is( $c4->name, 'ASCII' ); is( $c4->command, 'ASCII' ); ok( !$c4->negative ); my $c5 = FormValidator::Simple::Constraint->new( [qw/LENGTH 3 10/] ); is( $c5->name, 'LENGTH' ); is( $c5->command, 'LENGTH' ); ok( !$c5->negative ); my $args5 = $c5->args; is( $args5->[0], 3 ); is( $args5->[1], 10 ); my $c6 = FormValidator::Simple::Constraint->new( [qw/NOT_LENGTH 2 5/] ); is( $c6->name, 'NOT_LENGTH' ); is( $c6->command, 'LENGTH' ); ok( $c6->negative ); my $args6 = $c6->args; is( $args6->[0], 2 ); is( $args6->[1], 5 ); FormValidator-Simple-0.29/t/02_constraints.t000644 000765 000024 00000001744 11670056435 021606 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 11; BEGIN{ use_ok("FormValidator::Simple::Constraints") } my $constraints = FormValidator::Simple::Constraints->new; ok( !$constraints->needs_blank_check ); require FormValidator::Simple::Constraint; my $c1 = FormValidator::Simple::Constraint->new('INT'); my $c2 = FormValidator::Simple::Constraint->new('ASCII'); my $c3 = FormValidator::Simple::Constraint->new([qw/LENGTH 5 10/]); is( $constraints->records_count, 0 ); $constraints->append($c1); $constraints->append($c2); $constraints->append($c3); is( $constraints->records_count, 3 ); my $c4 = $constraints->get_record_at(1); is( $c4->name, 'ASCII' ); my $ite = $constraints->iterator; isa_ok( $ite, "FormValidator::Simple::Constraint::Iterator" ); my $c5 = $ite->next; my $c6 = $ite->next; my $c7 = $ite->next; my $c8 = $ite->next; is( $c5->name, 'INT' ); is( $c6->name, 'ASCII' ); is( $c7->name, 'LENGTH' ); is( $c8, undef ); $ite->reset; my $c9 = $ite->next; is( $c9->name, 'INT' ); FormValidator-Simple-0.29/t/03_profile.t000644 000765 000024 00000005370 11670056435 020677 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 42; BEGIN{ use_ok("FormValidator::Simple::Profile") } my $rec = FormValidator::Simple::Profile::Record->new; $rec->set_keys( { id => ['key'] } ); is( $rec->name, 'id' ); is( $rec->keys->[0], 'key' ); $rec->set_keys( { 'id2' => 'key2' } ); is( $rec->name, 'id2' ); is( $rec->keys->[0], 'key2' ); $rec->set_keys( { 'id3' => [qw/key3 key4 key5/] } ); is( $rec->name, 'id3' ); is( $rec->keys->[0], 'key3' ); is( $rec->keys->[1], 'key4' ); is( $rec->keys->[2], 'key5' ); $rec->set_keys( 'id4' ); is( $rec->name, 'id4' ); is( $rec->keys->[0], 'id4' ); isa_ok( $rec->constraints, "FormValidator::Simple::Constraints" ); $rec->set_constraints( ['INT'] ); my $c1 = $rec->constraints->get_record_at(0); is( $c1->name, 'INT' ); $rec->set_constraints( [qw/ASCII INT/,[qw/LENGTH 4 10/]] ); my $c2 = $rec->constraints->get_record_at(0); my $c3 = $rec->constraints->get_record_at(1); my $c4 = $rec->constraints->get_record_at(2); is( $rec->constraints->records_count, 3 ); ok( !$rec->constraints->needs_blank_check ); is( $c2->name, 'ASCII' ); is( $c3->name, 'INT' ); is( $c4->name, 'LENGTH' ); is( $c4->args->[0], 4 ); is( $c4->args->[1], 10 ); $rec->set_constraints( [qw/NOT_BLANK ASCII INT/] ); my $c5 = $rec->constraints->get_record_at(0); my $c6 = $rec->constraints->get_record_at(1); is( $rec->constraints->records_count, 2 ); ok( $rec->constraints->needs_blank_check ); is( $c5->name, 'ASCII' ); is( $c6->name, 'INT' ); $rec->set_constraints('INT'); my $c7 = $rec->constraints->get_record_at(0); is( $c7->name, 'INT' ); $rec->set_constraints( ['NOT_BLANK'] ); is( $rec->constraints->records_count, 0 ); ok( $rec->constraints->needs_blank_check ); my $prof = FormValidator::Simple::Profile->new( [ id => [qw/NOT_BLANK/], { name => [qw/name1 name2/] } => [qw/ANY/], pass => [qw/NOT_BLANK ASCII/,['LENGTH', 4, 10]] ] ); my $prec1 = $prof->get_record_at(0); my $prec2 = $prof->get_record_at(1); my $prec3 = $prof->get_record_at(2); is( $prof->records_count, 3 ); isa_ok( $prec1, "FormValidator::Simple::Profile::Record" ); isa_ok( $prec2, "FormValidator::Simple::Profile::Record" ); isa_ok( $prec3, "FormValidator::Simple::Profile::Record" ); ok( $prec1->constraints->needs_blank_check ); is( $prec1->constraints->records_count, 0 ); ok( !$prec2->constraints->needs_blank_check ); is( $prec2->constraints->records_count, 1 ); ok( $prec3->constraints->needs_blank_check ); is( $prec3->constraints->records_count, 2 ); my $ite = $prof->iterator; isa_ok( $ite, "FormValidator::Simple::Profile::Iterator" ); my $prec4 = $ite->next; my $prec5 = $ite->next; my $prec6 = $ite->next; my $prec7 = $ite->next; is( $prec7, undef ); is( $prec4->name, 'id' ); is( $prec5->name, 'name' ); is( $prec6->name, 'pass' ); FormValidator-Simple-0.29/t/04_result.t000644 000765 000024 00000001122 11670056435 020545 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 13; BEGIN{ use_ok("FormValidator::Simple::Result") } my $r1 = FormValidator::Simple::Result->new('id1'); is( $r1->name, 'id1' ); ok( !$r1->is_blank ); $r1->set('ASCII', 1 ); ok( $r1->is_valid ); ok( !$r1->is_invalid ); $r1->set('INT', undef ); $r1->set('LENGTH', undef ); ok( !$r1->is_valid ); ok( $r1->is_invalid ); ok( $r1->is_valid_for('ASCII') ); ok( !$r1->is_valid_for('INT') ); ok( !$r1->is_valid_for('LENGTH') ); ok( !$r1->is_invalid_for('ASCII') ); ok( $r1->is_invalid_for('INT') ); ok( $r1->is_invalid_for('LENGTH') ); FormValidator-Simple-0.29/t/05_results.t000644 000765 000024 00000003131 11670056435 020733 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 34; BEGIN{ use_ok("FormValidator::Simple::Results") } my $results = FormValidator::Simple::Results->new; $results->register('r1'); $results->register('r2'); $results->register('r3'); my $valids = $results->valid; is( scalar(keys %$valids), 3 ); ok( exists $valids->{r1}); ok( exists $valids->{r2}); ok( !$results->has_missing ); ok( !$results->has_invalid ); $results->record('r1')->is_blank(1); my $valids2 = $results->valid; is( scalar(keys %$valids2), 2 ); ok( exists $valids2->{r2}); ok( exists $valids2->{r3}); ok( $results->has_error ); ok( !$results->success ); ok( $results->has_blank ); ok( !$results->has_invalid ); ok( $results->missing('r1') ); my @missings = $results->missing; is( scalar(@missings), 1 ); is( $missings[0], 'r1' ); $results->record('r2')->set( 'ASCII' => 1 ); $results->record('r2')->set( 'INT' => undef ); ok( $results->has_error ); ok( $results->has_invalid ); ok( !$results->success ); my @invalids = $results->invalid; is( scalar(@invalids), 1 ); is( $invalids[0], 'r2' ); ok( !$results->invalid('r1') ); ok( $results->invalid('r2') ); ok( !$results->invalid('r3') ); ok( !$results->invalid('r2', 'ASCII') ); ok( $results->invalid('r2', 'INT' ) ); $results->record('r3')->data('data'); my $valids3 = $results->valid; is( scalar(keys %$valids3), 1 ); ok( exists $valids3->{r3}); is( $results->valid('r3'), 'data' ); $results->clear; is(scalar keys %{$results->valid}, 0); is(scalar @{$results->missing}, 0); ok(!$results->has_error); ok(!$results->has_invalid); ok($results->success); FormValidator-Simple-0.29/t/06_data.t000644 000765 000024 00000001154 11670056435 020147 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 9; BEGIN{ use_ok("FormValidator::Simple::Data") } use CGI; my $q = CGI->new; $q->param('key1' => 'val1'); $q->param('key2' => 'val2'); $q->param('key3' => 'val3_1', 'val3_2' ); my $data = FormValidator::Simple::Data->new($q); isa_ok($data, "FormValidator::Simple::Data"); my $val1 = $data->param(['key1']); is( scalar(@$val1), 1 ); is( $val1->[0], 'val1' ); my $val2 = $data->param(['key3']); is( $val2->[0][0], 'val3_1' ); is( $val2->[0][1], 'val3_2' ); my $val3 = $data->param(['key1','key2']); is( scalar(@$val3), 2 ); is( $val3->[0], 'val1' ); is( $val3->[1], 'val2' ); FormValidator-Simple-0.29/t/07_simple.t000644 000765 000024 00000003660 11670056435 020534 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 24; use CGI; BEGIN { use_ok("FormValidator::Simple"); } my $q = CGI->new; $q->param(text1 => 'HOGEHOGE' ); $q->param(text2 => 'HOGEHOGEHOGE' ); $q->param(int => 7 ); $q->param(blank => "" ); $q->param(email => 'lyo.kato@gmail.com' ); my $results = FormValidator::Simple->check( $q, [ text1 => [qw/NOT_BLANK/], text2 => [qw/NOT_BLANK/], int => [qw/INT/], blank => [qw/NOT_BLANK/], email => [qw/EMAIL_LOOSE/], ] ); isa_ok( $results, "FormValidator::Simple::Results" ); ok($results->missing('blank')); ok(!$results->valid('blank')); ok(!$results->invalid('blank')); ok($results->has_missing); ok(!$results->has_invalid); is($results->valid('text1'), 'HOGEHOGE' ); is($results->valid('int'), 7 ); is($results->valid('email'), 'lyo.kato@gmail.com'); ok(!$results->invalid('text1')); ok(!$results->invalid('int')); ok(!$results->invalid('email')); ok(!$results->missing('text1')); ok(!$results->missing('int')); ok(!$results->missing('email')); my @missings = $results->missing; my @invalids = $results->invalid; my $valids = $results->valid; is(scalar(@missings), 1); is(scalar(@invalids), 0); is(scalar(keys %$valids), 4); my $valid = FormValidator::Simple->new; $valid->check( $q => [ text1 => [qw/NOT_BLANK ASCII/], ] ); $valid->check( $q => [ text2 => [qw/NOT_BLANK NOT_ASCII/], ] ); my $results2 = $valid->results; ok(!$results2->invalid('text1')); ok($results2->invalid('text2')); $valid->set_invalid( hoge => 'HOGE' ); my $results3 = $valid->results; ok($results3->invalid('hoge')); ok($results3->invalid( hoge => 'HOGE' )); # make sure check doesn't eat the profile my $profile = [ text => [qw/NOT_BLANK INT/], int => [qw/NOT_BLANK INT/], ]; my $r3 = FormValidator::Simple->check( $q => $profile ); is_deeply( $profile, [ text => [qw/NOT_BLANK INT/], int => [qw/NOT_BLANK INT/], ] ); FormValidator-Simple-0.29/t/08_length.t000644 000765 000024 00000001612 11670056435 020520 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 7; use CGI; BEGIN{ use_ok("FormValidator::Simple") } my $q = CGI->new; $q->param( text => 'text' ); my $r = FormValidator::Simple->check( $q => [ text => [qw/NOT_BLANK/,[qw/LENGTH 4/]], ] ); ok(!$r->invalid('text')); my $r2 = FormValidator::Simple->check( $q => [ text => [qw/NOT_BLANK/,[qw/LENGTH 2 5/]], ] ); ok(!$r2->invalid('text')); my $r3 = FormValidator::Simple->check( $q => [ text => [qw/NOT_BLANK/,[qw/LENGTH 5 7/]], ] ); ok($r3->invalid('text')); my $r4 = FormValidator::Simple->check( $q => [ text => [qw/NOT_BLANK/, [qw/NOT_LENGTH 4/]], ] ); ok($r4->invalid('text')); my $r5 = FormValidator::Simple->check( $q => [ text => [qw/NOT_BLANK/,[qw/NOT_LENGTH 2 5/]], ] ); ok($r5->invalid('text')); my $r6 = FormValidator::Simple->check( $q => [ text => [qw/NOT_BLANK/,[qw/NOT_LENGTH 5 7/]], ] ); ok(!$r6->invalid('text')); FormValidator-Simple-0.29/t/09_ascii.t000644 000765 000024 00000001001 11670056435 020320 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 5; use CGI; BEGIN{ use_ok("FormValidator::Simple") } my $q = CGI->new; $q->param( param1 => 'abcd' ); $q->param( param2 => '日本語' ); my $r = FormValidator::Simple->check( $q => [ param1 => [qw/ASCII/], param2 => [qw/ASCII/], ] ); ok(!$r->invalid('param1')); ok($r->invalid('param2')); my $r2 = FormValidator::Simple->check( $q => [ param1 => [qw/NOT_ASCII/], param2 => [qw/NOT_ASCII/], ] ); ok($r2->invalid('param1')); ok(!$r2->invalid('param2')); FormValidator-Simple-0.29/t/10_int.t000644 000765 000024 00000001004 11670056435 020015 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 5; use CGI; BEGIN{ use_ok("FormValidator::Simple") } my $q = CGI->new; $q->param( text => 'text' ); $q->param( int => 12345 ); my $r = FormValidator::Simple->check( $q => [ text => [qw/NOT_BLANK INT/], int => [qw/NOT_BLANK INT/], ] ); ok($r->invalid('text')); ok(!$r->invalid('int')); my $r2 = FormValidator::Simple->check( $q => [ text => [qw/NOT_BLANK NOT_INT/], int => [qw/NOT_BLANK NOT_INT/], ] ); ok(!$r2->invalid('text')); ok($r2->invalid('int')); FormValidator-Simple-0.29/t/11_space.t000644 000765 000024 00000001026 11670056435 020323 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 5; use CGI; BEGIN{ use_ok("FormValidator::Simple") } my $q = CGI->new; $q->param( param1 => 'text' ); $q->param( param2 => ' ' ); my $r = FormValidator::Simple->check( $q => [ param1 => [qw/NOT_BLANK SP/], param2 => [qw/NOT_BLANK SP/], ] ); ok($r->invalid('param1')); ok(!$r->invalid('param2')); my $r2 = FormValidator::Simple->check( $q => [ param1 => [qw/NOT_BLANK NOT_SP/], param2 => [qw/NOT_BLANK NOT_SP/], ] ); ok(!$r2->invalid('param1')); ok($r2->invalid('param2')); FormValidator-Simple-0.29/t/12_duplication.t000644 000765 000024 00000001643 11670056435 021551 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 5; use CGI; BEGIN { use_ok("FormValidator::Simple") } my $q = CGI->new; $q->param( email1 => 'lyo.kato@gmail.com' ); $q->param( email2 => 'lyo.kato@gmail.com' ); my $r = FormValidator::Simple->check( $q => [ email1 => [qw/NOT_BLANK EMAIL_LOOSE/], email2 => [qw/NOT_BLANK EMAIL_LOOSE/], { email_dup => [qw/email1 email2/] } => [qw/DUPLICATION/], ] ); ok(!$r->invalid('email_dup')); my $r2 = FormValidator::Simple->check( $q => [ { email_dup => [qw/email1 email2/] } => [qw/NOT_DUPLICATION/], ] ); ok($r2->invalid('email_dup')); $q->param( email2 => 'lyokato@gmail.com' ); my $r3 = FormValidator::Simple->check( $q => [ { email_dup => [qw/email1 email2/] } => [qw/DUPLICATION/], ] ); ok($r3->invalid('email_dup')); my $r4 = FormValidator::Simple->check( $q => [ { email_dup => [qw/email1 email2/] } => [qw/NOT_DUPLICATION/], ] ); ok(!$r4->invalid('email_dup')); FormValidator-Simple-0.29/t/13_datetime.t000644 000765 000024 00000004414 11670056435 021032 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 13; use CGI; BEGIN{ use_ok("FormValidator::Simple") } my $q = CGI->new; $q->param( year => 2005 ); $q->param( month => 11 ); $q->param( day => 25 ); $q->param( hour => 12 ); $q->param( min => 40 ); $q->param( sec => 5 ); my $r = FormValidator::Simple->check( $q => [ { date => [qw/year month day/] } => [qw/DATE/], ] ); ok(!$r->invalid('date')); my $r2 = FormValidator::Simple->check( $q => [ { date => [qw/year month day/] } => [qw/NOT_DATE/], ] ); ok($r2->invalid('date')); $q->param( month => 2 ); $q->param( day => 30 ); my $r3 = FormValidator::Simple->check( $q => [ { date => [qw/year month day/] } => [qw/DATE/], ] ); ok($r3->invalid('date')); my $r4 = FormValidator::Simple->check( $q => [ { date => [qw/year month day/] } => [qw/NOT_DATE/], ] ); ok(!$r4->invalid('date')); my $r5 = FormValidator::Simple->check( $q => [ { time => [qw/hour min sec/] } => [qw/TIME/], ] ); ok(!$r5->invalid('time')); my $r6 = FormValidator::Simple->check( $q => [ { time => [qw/hour min sec/] } => [qw/NOT_TIME/], ] ); ok($r6->invalid('time')); $q->param( hour => 25 ); my $r7 = FormValidator::Simple->check( $q => [ { time => [qw/hour min sec/] } => [qw/TIME/], ] ); ok($r7->invalid('time')); my $r8 = FormValidator::Simple->check( $q => [ { time => [qw/hour min sec/] } => [qw/NOT_TIME/] ] ); ok(!$r8->invalid('time')); my $q2 = CGI->new; $q2->param( year => 2005 ); $q2->param( month => 12 ); $q2->param( day => 29 ); $q2->param( hour => 5 ); $q2->param( min => 22 ); $q2->param( sec => 30 ); my $r9 = FormValidator::Simple->check( $q2 => [ { datetime => [qw/year month day hour min sec/] } => [qw/DATETIME/] ] ); ok(!$r9->invalid('datetime')); my $r10 = FormValidator::Simple->check( $q2 => [ { datetime => [qw/year month day hour min sec/] } => [qw/NOT_DATETIME/] ] ); ok($r10->invalid('datetime')); $q2->param( month => 2 ); $q2->param( day => 30 ); my $r11 = FormValidator::Simple->check( $q2 => [ { datetime => [qw/year month day hour min sec/] } => [qw/DATETIME/] ] ); ok($r11->invalid('datetime')); my $r12 = FormValidator::Simple->check( $q2 => [ { datetime => [qw/year month day hour min sec/] } => [qw/NOT_DATETIME/], ] ); ok(!$r12->invalid('datetime')); FormValidator-Simple-0.29/t/14_regex.t000644 000765 000024 00000000763 11670056435 020354 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 4; use CGI; BEGIN{ use_ok("FormValidator::Simple") } my $q = CGI->new; $q->param( hoge => 'hogefoo' ); my $r = FormValidator::Simple->check( $q => [ hoge => [ ['REGEX', qr/^hoge/] ], ] ); ok(!$r->invalid('hoge')); my $r2 = FormValidator::Simple->check( $q => [ hoge => [ ['NOT_REGEX', qr/^hoge/] ], ] ); ok($r2->invalid('hoge')); my $r3 = FormValidator::Simple->check( $q => [ hoge => [ ['REGEX', qr/^foo/] ], ] ); ok($r3->invalid('hoge')); FormValidator-Simple-0.29/t/15_any.t000644 000765 000024 00000001324 11670056435 020024 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 5; use CGI; BEGIN{ use_ok("FormValidator::Simple") } my $q = CGI->new; $q->param( hoge => 1 ); $q->param( foo => '' ); $q->param( bar => '' ); my $r = FormValidator::Simple->check( $q => [ { any => [qw/hoge foo bar/] } => [qw/ANY/], ] ); ok(!$r->invalid('any')); my $r2 = FormValidator::Simple->check( $q => [ { any => [qw/hoge foo bar/] } => [qw/NOT_ANY/], ] ); ok($r2->invalid('any')); $q->param( hoge => '' ); my $r3 = FormValidator::Simple->check( $q => [ { any => [qw/hoge foo bar/] } => [qw/ANY/] ] ); ok($r3->invalid('any')); my $r4 = FormValidator::Simple->check( $q => [ { any => [qw/hoge foo bar/] } => [qw/NOT_ANY/] ] ); ok(!$r4->invalid('any')); FormValidator-Simple-0.29/t/16_plugin.t000644 000765 000024 00000001211 11670056435 020527 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 5; use CGI; use lib 't/lib'; BEGIN { require_ok("FormValidator::Simple") } FormValidator::Simple->import(qw/Sample +MyNamespace::MyPlugin/); my $q = CGI->new; $q->param( sample1 => 'hogehoge' ); $q->param( sample2 => 'sample' ); $q->param( myplugin1 => 'hogehoge' ); $q->param( myplugin2 => 'myplugin' ); my $r = FormValidator::Simple->check( $q => [ sample1 => [qw/SAMPLE/], sample2 => [qw/SAMPLE/], myplugin1 => [qw/MYPLUGIN/], myplugin2 => [qw/MYPLUGIN/], ] ); ok($r->invalid('sample1')); ok(!$r->invalid('sample2')); ok($r->invalid('myplugin1')); ok(!$r->invalid('myplugin2')); FormValidator-Simple-0.29/t/17_pod.t000644 000765 000024 00000000276 11670056435 020026 0ustar00lyokatostaff000000 000000 use Test::More; eval "use Test::Pod 1.14"; plan skip_all => 'Test::Pod 1.14 required' if $@; plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; all_pod_files_ok(); FormValidator-Simple-0.29/t/18_invalids.t000644 000765 000024 00000001746 11670056435 021061 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 16; use CGI; BEGIN{ use_ok("FormValidator::Simple") } my $q = CGI->new; $q->param( hoge => 'test' ); $q->param( hoge2 => 'test' ); $q->param( hoge3 => '' ); my $r = FormValidator::Simple->check( $q => [ hoge => [ [qw/LENGTH 10/], [qw/INT/], [qw/NOT_ASCII/] ], hoge2 => [ [qw/LENGTH 10/] ], hoge3 => [ 'NOT_BLANK' ], ] ); my $invalids = $r->invalid('hoge'); is(scalar(@$invalids), 3); is($invalids->[0], 'LENGTH'); is($invalids->[1], 'INT'); is($invalids->[2], 'NOT_ASCII'); my @errors = $r->error; is($errors[0], 'hoge'); is($errors[1], 'hoge2'); is($errors[2], 'hoge3'); my @inv = $r->invalid; is($inv[0], 'hoge'); is($inv[1], 'hoge2'); my @mis = $r->missing; is($mis[0], 'hoge3'); my $hoge_errors = $r->error('hoge'); is($hoge_errors->[0], 'LENGTH'); is($hoge_errors->[1], 'INT'); is($hoge_errors->[2], 'NOT_ASCII'); my $hoge_errors2 = $r->error('hoge3'); is($hoge_errors2->[0], 'NOT_BLANK'); ok($r->error( hoge3 => 'NOT_BLANK')); FormValidator-Simple-0.29/t/19_url.t000644 000765 000024 00000000557 11670056435 020052 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 3; use CGI; BEGIN{ use_ok("FormValidator::Simple") } my $q = CGI->new; $q->param( hoge => 'http://www.lost-season.jp/mt/' ); $q->param( foo => 'lyo.kato@gmail.com' ); my $r = FormValidator::Simple->check( $q => [ hoge => [ 'HTTP_URL' ], foo => [ 'HTTP_URL' ], ] ); ok(!$r->invalid('hoge')); ok($r->invalid('foo')); FormValidator-Simple-0.29/t/20_numeric_cmp.t000644 000765 000024 00000002722 11670057215 021532 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 15; use CGI; BEGIN{ use_ok("FormValidator::Simple") } my $q = CGI->new; $q->param( age1 => 25 ); $q->param( age2 => 25 ); $q->param( age3 => 25 ); $q->param( age4 => 25 ); my $r = FormValidator::Simple->check( $q => [ age1 => [ 'INT', [qw/GREATER_THAN 20/] ], age2 => [ 'INT', [qw/LESS_THAN 30/] ], age3 => [ 'INT', [qw/EQUAL_TO 25/] ], age4 => [ 'INT', [qw/BETWEEN 20 30/] ], ] ); ok(!$r->invalid('age1')); ok(!$r->invalid('age2')); ok(!$r->invalid('age3')); ok(!$r->invalid('age4')); my $r2 = FormValidator::Simple->check( $q => [ age1 => [ 'INT', [qw/GREATER_THAN 30/] ], age2 => [ 'INT', [qw/LESS_THAN 20/] ], age3 => [ 'INT', [qw/EQUAL_TO 22/] ], age4 => [ 'INT', [qw/BETWEEN 0 22/] ], ] ); ok($r2->invalid('age1')); ok($r2->invalid('age2')); ok($r2->invalid('age3')); ok($r2->invalid('age4')); my $r3 = FormValidator::Simple->check( $q => [ age1 => [ 'INT', [qw/GREATER_THAN 0/] ], age2 => [ 'INT', [qw/LESS_THAN 0/] ], age3 => [ 'INT', [qw/EQUAL_TO 0/] ], ] ); ok(!$r3->invalid('age1')); ok($r3->invalid('age2')); ok($r3->invalid('age3')); my $q2 = CGI->new; $q2->param( num1 => 3 ); $q2->param( num2 => 23.4 ); $q2->param( num3 => -12.4 ); my $r4 = FormValidator::Simple->check( $q2 => [ num1 => [ [qw/BETWEEN -4 2/] ], num2 => [ [qw/BETWEEN 23.3 23.5/] ], num3 => [ [qw/BETWEEN -20 -10/] ], ] ); ok($r4->invalid('num1')); ok(!$r4->invalid('num2')); ok(!$r4->invalid('num3')); FormValidator-Simple-0.29/t/21_decimal.t000644 000765 000024 00000001016 11670056435 020626 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 5; BEGIN{ use_ok("FormValidator::Simple") } use CGI; my $q = CGI->new; $q->param( num1 => '123.456' ); $q->param( num2 => '123' ); $q->param( num3 => '1234' ); $q->param( num4 => '123.4567' ); my $r = FormValidator::Simple->check( $q => [ num1 => [ [qw/DECIMAL 3 3/] ], num2 => [ [qw/DECIMAL 3 3/] ], num3 => [ [qw/DECIMAL 3 3/] ], num4 => [ [qw/DECIMAL 3 3/] ], ] ); ok(!$r->invalid('num1')); ok(!$r->invalid('num2')); ok($r->invalid('num3')); ok($r->invalid('num4')); FormValidator-Simple-0.29/t/22_messages.t000644 000765 000024 00000006127 11670056435 021050 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 25; BEGIN{ use_ok("FormValidator::Simple") } use CGI; my $data = { DEFAULT => { data4 => { DEFAULT => 'input data4', }, }, test => { data1 => { NOT_BLANK => 'input data1', INT => 'input integer for data1', LENGTH => 'data1 has wrong length', }, data2 => { DEFAULT => 'default error for data2', }, data3 => { NOT_BLANK => 'input data3', }, }, }; FormValidator::Simple->set_messages( $data ); my $q = CGI->new; $q->param( data1 => 'hoge' ); $q->param( data2 => '123' ); $q->param( data3 => '' ); $q->param( data4 => '' ); my $r = FormValidator::Simple->check( $q => [ data1 => [qw/NOT_BLANK INT/, [qw/LENGTH 0 3/] ], data2 => [qw/NOT_BLANK ASCII/, [qw/LENGTH 5/]], data3 => [qw/NOT_BLANK/], data4 => [qw/NOT_BLANK/], ] ); my $messages = $r->messages('test'); is($messages->[0], 'input integer for data1'); is($messages->[1], 'data1 has wrong length'); is($messages->[2], 'default error for data2'); is($messages->[3], 'input data3'); is($messages->[4], 'input data4'); # check that messages on object don't trash class messages my $fvs = FormValidator::Simple->new; is_deeply(FormValidator::Simple->messages->{_data}, $data); # set your own my $objdata = { object => { object1 => { NOT_BLANK => 'not blank for object1', }, object2 => { LENGTH => 'length wrong for object2', }, } }; # object has its messages $fvs->set_messages( $objdata ); is_deeply($fvs->messages->{_data}, $objdata); # class should be int tact is_deeply(FormValidator::Simple->messages->{_data}, $data); my $oq = CGI->new; $oq->param( object1 => '' ); $oq->param( object2 => 'abcdef' ); my $or = $fvs->check( $oq => [ object1 => [ [qw/NOT_BLANK/] ], object2 => [ [qw/LENGTH 1 2/] ], ] ); my $omessages = $or->messages('object'); is($omessages->[0], 'not blank for object1'); is($omessages->[1], 'length wrong for object2'); my $field_messages = $or->field_messages('object'); is(scalar @{ $field_messages->{object1} }, 1); is(scalar @{ $field_messages->{object2} }, 1); is($field_messages->{object1}[0], 'not blank for object1'); is($field_messages->{object2}[0], 'length wrong for object2'); # make sure the class version still works: my $nr = FormValidator::Simple->check( $q => [ data1 => [qw/NOT_BLANK INT/, [qw/LENGTH 0 3/] ], data2 => [qw/NOT_BLANK ASCII/, [qw/LENGTH 5/] ], data3 => [qw/NOT_BLANK/], data4 => [qw/NOT_BLANK/], ] ); my $nmessages = $nr->messages('test'); is($nmessages->[0], 'input integer for data1'); is($nmessages->[1], 'data1 has wrong length'); is($nmessages->[2], 'default error for data2'); is($nmessages->[3], 'input data3'); is($nmessages->[4], 'input data4'); my $nfmessages = $nr->field_messages('test'); is($nfmessages->{data1}[0], 'input integer for data1'); is($nfmessages->{data1}[1], 'data1 has wrong length'); is($nfmessages->{data2}[0], 'default error for data2'); is($nfmessages->{data3}[0], 'input data3'); is($nfmessages->{data4}[0], 'input data4'); FormValidator-Simple-0.29/t/23_messages_yaml.t000644 000765 000024 00000001737 11670056435 022075 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 9; BEGIN{ use_ok("FormValidator::Simple") } use CGI; my $conf_file = "t/conf/messages.yml"; FormValidator::Simple->set_messages($conf_file); my $q = CGI->new; $q->param( data1 => 'hoge' ); $q->param( data2 => '123' ); $q->param( data3 => '' ); my $r = FormValidator::Simple->check( $q => [ data1 => [qw/NOT_BLANK INT/, [qw/LENGTH 0 3/] ], data2 => [qw/NOT_BLANK ASCII/, [qw/LENGTH 5/]], data3 => [qw/NOT_BLANK/], ] ); my $messages = $r->messages('test'); is($messages->[0], 'input integer for data1'); is($messages->[1], 'data1 has wrong length'); is($messages->[2], 'default error for data2'); is($messages->[3], 'input data3'); FormValidator::Simple->set_message_format('

%s

'); my $messages2 = $r->messages('test'); is($messages2->[0], '

input integer for data1

'); is($messages2->[1], '

data1 has wrong length

'); is($messages2->[2], '

default error for data2

'); is($messages2->[3], '

input data3

'); FormValidator-Simple-0.29/t/24_options.t000644 000765 000024 00000000651 11670056435 020732 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 5; BEGIN{ use_ok("FormValidator::Simple") } BEGIN{ use_ok("FormValidator::Simple::Validator") } FormValidator::Simple->set_option( foo => 'oof', bar => 'rab', ); my $o = FormValidator::Simple::Validator->options; is($o->{foo}, 'oof'); is($o->{bar}, 'rab'); FormValidator::Simple->new( buz => 'zub' ); my $o2 = FormValidator::Simple::Validator->options; is($o2->{buz}, 'zub'); FormValidator-Simple-0.29/t/25_all.t000644 000765 000024 00000000564 11670056435 020013 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 3; BEGIN{ use_ok("FormValidator::Simple") } use CGI; my $q = CGI->new; $q->param( foo => 'foo' ); $q->param( bar => 'bar' ); $q->param( buz => '' ); my $r = FormValidator::Simple->check( $q => [ { all1 => [qw/foo bar/] } => ['ALL'], { all2 => [qw/bar buz/] } => ['ALL'] ] ); ok(!$r->invalid('all1')); ok($r->invalid('all2')); FormValidator-Simple-0.29/t/26_inarray.t000644 000765 000024 00000000660 11670056435 020706 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 4; BEGIN{ use_ok("FormValidator::Simple") } use CGI; my $q = CGI->new; $q->param( foo => 'foo' ); $q->param( bar => 'bar' ); $q->param( buz => 0 ); my $r = FormValidator::Simple->check( $q => [ foo => [ [qw/IN_ARRAY foo bar buz/] ], bar => [ [qw/IN_ARRAY foo buz/] ], buz => [ [qw/IN_ARRAY 0 1/] ], ] ); ok(!$r->invalid('foo')); ok($r->invalid('bar')); ok(!$r->invalid('buz')); FormValidator-Simple-0.29/t/27_set_invalid.t000644 000765 000024 00000000703 11670056435 021541 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 6; use CGI; BEGIN { use_ok("FormValidator::Simple"); } my $q = CGI->new; $q->param(foo => 'FooBarBaz'); my $results = FormValidator::Simple->check( $q, [ foo => [qw/NOT_BLANK/], ] ); ok($results->valid('foo')); ok(!$results->invalid('foo')); $results->set_invalid(foo => 'ANOTHER_CONSTRAINT'); ok(!$results->valid('foo')); ok($results->invalid('foo')); ok($results->invalid('foo', 'ANOTHER_CONSTRAINT')); FormValidator-Simple-0.29/t/28_decode.t000644 000765 000024 00000003215 11670056435 020465 0ustar00lyokatostaff000000 000000 use strict; use Test::More tests => 17; BEGIN{ use_ok("FormValidator::Simple") } use CGI; my $conf_file = "t/conf/messages_ja.yml"; FormValidator::Simple->set_messages($conf_file); FormValidator::Simple->set_message_decode_from('utf-8'); my $q = CGI->new; $q->param( data1 => 'hoge' ); $q->param( data2 => '123' ); $q->param( data3 => '' ); my $r = FormValidator::Simple->check( $q => [ data1 => [qw/NOT_BLANK INT/, [qw/LENGTH 0 3/] ], data2 => [qw/NOT_BLANK ASCII/, [qw/LENGTH 5/]], data3 => [qw/NOT_BLANK/], ] ); my $messages = $r->messages('test'); ok (Encode::is_utf8($messages->[0])); ok (Encode::is_utf8($messages->[1])); ok (Encode::is_utf8($messages->[2])); ok (Encode::is_utf8($messages->[3])); is($messages->[0], Encode::decode('utf-8','data1は整数で入力してください。')); is($messages->[1], Encode::decode('utf-8','data1の長さが不正です。')); is($messages->[2], Encode::decode('utf-8','data2の値が不正です。')); is($messages->[3], Encode::decode('utf-8','data3を入力してください。')); FormValidator::Simple->set_message_format('

%s

'); my $messages2 = $r->messages('test'); ok (Encode::is_utf8($messages2->[0])); ok (Encode::is_utf8($messages2->[1])); ok (Encode::is_utf8($messages2->[2])); ok (Encode::is_utf8($messages2->[3])); is($messages2->[0], Encode::decode('utf-8','

data1は整数で入力してください。

')); is($messages2->[1], Encode::decode('utf-8','

data1の長さが不正です。

')); is($messages2->[2], Encode::decode('utf-8','

data2の値が不正です。

')); is($messages2->[3], Encode::decode('utf-8','

data3を入力してください。

')); FormValidator-Simple-0.29/t/conf/000755 000765 000024 00000000000 11670057572 017473 5ustar00lyokatostaff000000 000000 FormValidator-Simple-0.29/t/lib/000755 000765 000024 00000000000 11670057572 017314 5ustar00lyokatostaff000000 000000 FormValidator-Simple-0.29/t/lib/FormValidator/000755 000765 000024 00000000000 11670057572 022065 5ustar00lyokatostaff000000 000000 FormValidator-Simple-0.29/t/lib/MyNamespace/000755 000765 000024 00000000000 11670057572 021516 5ustar00lyokatostaff000000 000000 FormValidator-Simple-0.29/t/lib/MyNamespace/MyPlugin.pm000644 000765 000024 00000000331 11670056435 023612 0ustar00lyokatostaff000000 000000 package MyNamespace::MyPlugin; use strict; use FormValidator::Simple::Constants; sub MYPLUGIN { my ($class, $params, $args) = @_; my $data = $params->[0]; return $data =~ /myplugin/ ? TRUE : FALSE; } 1; FormValidator-Simple-0.29/t/lib/FormValidator/Simple/000755 000765 000024 00000000000 11670057572 023316 5ustar00lyokatostaff000000 000000 FormValidator-Simple-0.29/t/lib/FormValidator/Simple/Plugin/000755 000765 000024 00000000000 11670057572 024554 5ustar00lyokatostaff000000 000000 FormValidator-Simple-0.29/t/lib/FormValidator/Simple/Plugin/Sample.pm000644 000765 000024 00000000345 11670056435 026332 0ustar00lyokatostaff000000 000000 package FormValidator::Simple::Plugin::Sample; use strict; use FormValidator::Simple::Constants; sub SAMPLE { my ($class, $params, $args) = @_; my $data = $params->[0]; return $data =~ /sample/ ? TRUE : FALSE; } 1; FormValidator-Simple-0.29/t/conf/messages.yml000644 000765 000024 00000000425 11670056435 022023 0ustar00lyokatostaff000000 000000 test: data1: DEFAULT: default message for data1 NOT_BLANK: not blank message for data1 INT: input integer for data1 LENGTH: data1 has wrong length data2: DEFAULT: default error for data2 data3: NOT_BLANK: input data3 FormValidator-Simple-0.29/t/conf/messages_ja.yml000644 000765 000024 00000000536 11670056435 022500 0ustar00lyokatostaff000000 000000 test: data1: DEFAULT: data1の値が不正です。 NOT_BLANK: data1を入力してください。 INT: data1は整数で入力してください。 LENGTH: data1の長さが不正です。 data2: DEFAULT: data2の値が不正です。 data3: NOT_BLANK: data3を入力してください。 FormValidator-Simple-0.29/lib/FormValidator/000755 000765 000024 00000000000 11670057572 021622 5ustar00lyokatostaff000000 000000 FormValidator-Simple-0.29/lib/FormValidator/Simple/000755 000765 000024 00000000000 11670057572 023053 5ustar00lyokatostaff000000 000000 FormValidator-Simple-0.29/lib/FormValidator/Simple.pm000644 000765 000024 00000042506 11670057546 023421 0ustar00lyokatostaff000000 000000 package FormValidator::Simple; use strict; use base qw/Class::Accessor::Fast Class::Data::Inheritable Class::Data::Accessor/; use Class::Inspector; use UNIVERSAL::require; use Scalar::Util qw/blessed/; use FormValidator::Simple::Results; use FormValidator::Simple::Exception; use FormValidator::Simple::Data; use FormValidator::Simple::Profile; use FormValidator::Simple::Validator; use FormValidator::Simple::Constants; use FormValidator::Simple::Messages; our $VERSION = '0.29'; __PACKAGE__->mk_classaccessors(qw/data prof results/); __PACKAGE__->mk_classaccessor( messages => FormValidator::Simple::Messages->new ); sub import { my $class = shift; foreach my $plugin (@_) { my $plugin_class; if ($plugin =~ /^\+(.*)/) { $plugin_class = $1; } else { $plugin_class = "FormValidator::Simple::Plugin::$plugin"; } $class->load_plugin($plugin_class); } } sub load_plugin { my ($proto, $plugin) = @_; my $class = ref $proto || $proto; unless (Class::Inspector->installed($plugin)) { FormValidator::Simple::Exception->throw( qq/$plugin isn't installed./ ); } $plugin->require; if ($@) { FormValidator::Simple::Exception->throw( qq/Couldn't require "$plugin", "$@"./ ); } { no strict 'refs'; push @FormValidator::Simple::Validator::ISA, $plugin; } } sub set_option { my $class = shift; while ( my ($key, $val) = splice @_, 0, 2 ) { FormValidator::Simple::Validator->options->{$key} = $val; } } sub set_messages { my ($proto, $file) = @_; my $class = ref $proto || $proto; if (blessed $proto) { $proto->messages(FormValidator::Simple::Messages->new)->load($file); if ($proto->results) { $proto->results->message($proto->messages); } else { $proto->results( FormValidator::Simple::Results->new( messages => $proto->messages, ) ); } } else { $class->messages->load($file); } } sub set_message_decode_from { my ($self, $decode_from) = @_; $self->messages->decode_from($decode_from); } sub set_message_format { my ($proto, $format) = @_; $format ||= ''; $proto->messages->format($format); } sub new { my $proto = shift; my $class = ref $proto || $proto; my $self = bless { }, $class; $self->_init(@_); return $self; } sub _init { my ($self, @args) = @_; my $class = ref $self; $class->set_option(@args); $self->results( FormValidator::Simple::Results->new( messages => $self->messages, ) ); } sub set_invalid { my ($self, $name, $type) = @_; unless (ref $self) { FormValidator::Simple::Exception->throw( qq/set_invalid is instance method./ ); } unless ($name && $type) { FormValidator::Simple::Exception->throw( qq/set_invalid needs two arguments./ ); } $self->results->set_result($name, $type, FALSE); } sub check { my ($proto, $input, $prof, $options) = @_; $options ||= {}; my $self = blessed $proto ? $proto : $proto->new(%$options); my $data = FormValidator::Simple::Data->new($input); my $prof_setting = FormValidator::Simple::Profile->new($prof); my $profile_iterator = $prof_setting->iterator; PROFILE: while ( my $profile = $profile_iterator->next ) { my $name = $profile->name; my $keys = $profile->keys; my $constraints = $profile->constraints; my $params = $data->param($keys); $self->results->register($name); $self->results->record($name)->data( @$params == 1 ? $params->[0] : ''); my $constraint_iterator = $constraints->iterator; if ( scalar @$params == 1 ) { unless ( defined $params->[0] && $params->[0] ne '' ) { if ( $constraints->needs_blank_check ) { $self->results->record($name)->is_blank( TRUE ); } next PROFILE; } } CONSTRAINT: while ( my $constraint = $constraint_iterator->next ) { my ($result, $data) = $constraint->check($params); $self->results->set_result($name, $constraint->name, $result); $self->results->record($name)->data($data) if $data; } } return $self->results; } 1; =head1 NAME FormValidator::Simple - validation with simple chains of constraints =head1 SYNOPSIS my $query = CGI->new; $query->param( param1 => 'ABCD' ); $query->param( param2 => 12345 ); $query->param( mail1 => 'lyo.kato@gmail.com' ); $query->param( mail2 => 'lyo.kato@gmail.com' ); $query->param( year => 2005 ); $query->param( month => 11 ); $query->param( day => 27 ); my $result = FormValidator::Simple->check( $query => [ param1 => ['NOT_BLANK', 'ASCII', ['LENGTH', 2, 5]], param2 => ['NOT_BLANK', 'INT' ], mail1 => ['NOT_BLANK', 'EMAIL_LOOSE'], mail2 => ['NOT_BLANK', 'EMAIL_LOOSE'], { mails => ['mail1', 'mail2' ] } => ['DUPLICATION'], { date => ['year', 'month', 'day'] } => ['DATE'], ] ); if ( $result->has_error ) { my $tt = Template->new({ INCLUDE_PATH => './tmpl' }); $tt->process('template.html', { result => $result }); } template example [% IF result.has_error %]

Found Input Error

[% END %] example2 [% IF result.has_error %] [% END %] =head1 DESCRIPTION This module provides you a sweet way of form data validation with simple constraints chains. You can write constraints on single line for each input data. This idea is based on Sledge::Plugin::Validator, and most of validation code is borrowed from this plugin. (Sledge is a MVC web application framework: http://sl.edge.jp [Japanese] ) The result object this module returns behaves like L. =head1 HOW TO SET PROFILE FormValidator::Simple->check( $q => [ #profile ] ); Use 'check' method. A hash reference includes input data, or an object of some class that has a method named 'param', for example L, is needed as first argument. And set profile as array reference into second argument. Profile consists of some pairs of input data and constraints. my $q = CGI->new; $q->param( param1 => 'hoge' ); FormValidator::Simple->check( $q => [ param1 => [ ['NOT_BLANK'], ['LENGTH', 4, 10] ], ] ); In this case, param1 is the name of a form element. and the array ref "[ ['NOT_BLANK']... ]" is a constraints chain. Write constraints chain as arrayref, and you can set some constraints into it. In the last example, two constraints 'NOT_BLANK', and 'LENGTH' are set. Each constraints is should be set as arrayref, but in case the constraint has no argument, it can be written as scalar text. FormValidator::Simple->check( $q => [ param1 => [ 'NOT_BLANK', ['LENGTH', 4, 10] ], ] ); Now, in this sample 'NOT_BLANK' constraint is not an arrayref, but 'LENGTH' isn't. Because 'LENGTH' has two arguments, 4 and 10. =head2 MULTIPLE DATA VALIDATION When you want to check about multiple input data, do like this. my $q = CGI->new; $q->param( mail1 => 'lyo.kato@gmail.com' ); $q->param( mail2 => 'lyo.kato@gmail.com' ); my $result = FormValidator::Simple->check( $q => [ { mails => ['mail1', 'mail2'] } => [ 'DUPLICATION' ], ] ) [% IF result.invalid('mails') %]

mail1 and mail2 aren't same.

[% END %] and here's an another example. my $q = CGI->new; $q->param( year => 2005 ); $q->param( month => 12 ); $q->param( day => 27 ); my $result = FormValidator::Simple->check( $q => [ { date => ['year', 'month', 'day'] } => [ 'DATE' ], ] ); [% IF result.invalid('date') %]

Set correct date.

[% END %] =head2 FLEXIBLE VALIDATION my $valid = FormValidator::Simple->new(); $valid->check( $q => [ param1 => [qw/NOT_BLANK ASCII/, [qw/LENGTH 4 10/] ], ] ); $valid->check( $q => [ param2 => [qw/NOT_BLANK/], ] ); my $results = $valid->results; if ( found some error... ) { $results->set_invalid('param3' => 'MY_ERROR'); } template example [% IF results.invalid('param1') %] ... [% END %] [% IF results.invalid('param2') %] ... [% END %] [% IF results.invalid('param3', 'MY_ERROR') %] ... [% END %] =head1 HOW TO SET OPTIONS Option setting is needed by some validation, especially in plugins. You can set them in two ways. FormValidator::Simple->set_option( dbic_base_class => 'MyProj::Model::DBIC', charset => 'euc', ); or $valid = FormValidator::Simple->new( dbic_base_class => 'MyProj::Model::DBIC', charset => 'euc', ); $valid->check(...) =head1 VALIDATION COMMANDS You can use follow variety validations. and each validations can be used as negative validation with 'NOT_' prefix. FormValidator::Simple->check( $q => [ param1 => [ 'INT', ['LENGTH', 4, 10] ], param2 => [ 'NOT_INT', ['NOT_LENGTH', 4, 10] ], ] ); =over 4 =item SP check if the data has space or not. =item INT check if the data is integer or not. =item UINT unsigined integer check. for example, if -1234 is input, the validation judges it invalid. =item DECIMAL $q->param( 'num1' => '123.45678' ); my $result = FormValidator::Simple->check( $q => [ num1 => [ ['DECIMAL', 3, 5] ], ] ); each numbers (3,5) mean maximum digits before/after '.' =item ASCII check is the data consists of only ascii code. =item LENGTH check the length of the data. my $result = FormValidator::Simple->check( $q => [ param1 => [ ['LENGTH', 4] ], ] ); check if the length of the data is 4 or not. my $result = FormValidator::Simple->check( $q => [ param1 => [ ['LENGTH', 4, 10] ], ] ); when you set two arguments, it checks if the length of data is in the range between 4 and 10. =item HTTP_URL verify it is a http(s)-url my $result = FormValidator::Simple->check( $q => [ param1 => [ 'HTTP_URL' ], ] ); =item SELECTED_AT_LEAST verify the quantity of selected parameters is counted over allowed minimum. Music Movie Game my $result = FormValidator::Simple->check( $q => [ hobby => ['NOT_BLANK', ['SELECTED_AT_LEAST', 2] ], ] ); =item REGEX check with regular expression. my $result = FormValidator::Simple->check( $q => [ param1 => [ ['REGEX', qr/^hoge$/ ] ], ] ); =item DUPLICATION check if the two data are same or not. my $result = FormValidator::Simple->check( $q => [ { duplication_check => ['param1', 'param2'] } => [ 'DUPLICATION' ], ] ); =item EMAIL check with L. =item EMAIL_MX check with L, including mx check. =item EMAIL_LOOSE check with L. =item EMAIL_LOOSE_MX check with L, including mx check. =item DATE check with L my $result = FormValidator::Simple->check( $q => [ { date => [qw/year month day/] } => [ 'DATE' ] ] ); =item TIME check with L my $result = FormValidator::Simple->check( $q => [ { time => [qw/hour min sec/] } => ['TIME'], ] ); =item DATETIME check with L my $result = FormValidator::Simple->check( $q => [ { datetime => [qw/year month day hour min sec/] } => ['DATETIME'] ] ); =item DATETIME_STRPTIME check with L. my $q = CGI->new; $q->param( datetime => '2006-04-26T19:09:21+0900' ); my $result = FormValidator::Simple->check( $q => [ datetime => [ [ 'DATETIME_STRPTIME', '%Y-%m-%dT%T%z' ] ], ] ); =item DATETIME_FORMAT check with DateTime::Format::***. for example, L, L, L and etc. my $q = CGI->new; $q->param( datetime => '2004-04-26 19:09:21' ); my $result = FormValidator::Simple->check( $q => [ datetime => [ [qw/DATETIME_FORMAT MySQL/] ], ] ); =item GREATER_THAN numeric comparison my $result = FormValidator::Simple->check( $q => [ age => [ ['GREATER_THAN', 25] ], ] ); =item LESS_THAN numeric comparison my $result = FormValidator::Simple->check( $q => [ age => [ ['LESS_THAN', 25] ], ] ); =item EQUAL_TO numeric comparison my $result = FormValidator::Simple->check( $q => [ age => [ ['EQUAL_TO', 25] ], ] ); =item BETWEEN numeric comparison my $result = FormValidator::Simple->check( $q => [ age => [ ['BETWEEN', 20, 25] ], ] ); =item ANY check if there is not blank data in multiple data. my $result = FormValidator::Simple->check( $q => [ { some_data => [qw/param1 param2 param3/] } => ['ANY'] ] ); =item IN_ARRAY check if the food ordered is in menu my $result = FormValidator::Simple->check( $q => [ food => [ ['IN_ARRAY', qw/noodle soba spaghetti/] ], ] }; =back =head1 HOW TO LOAD PLUGINS use FormValidator::Simple qw/Japanese CreditCard/; L, L are loaded. or use 'load_plugin' method. use FormValidator::Simple; FormValidator::Simple->load_plugin('FormValidator::Simple::Plugin::CreditCard'); If you want to load plugin which name isn't in FormValidator::Simple::Plugin namespace, use +. use FormValidator::Simple qw/+MyApp::ValidatorPlugin/; =head1 MESSAGE HANDLING You can custom your own message with key and type. [% IF result.has_error %] [% FOREACH key IN result.error %] [% FOREACH type IN result.error(key) %]

error message:[% type %] - [% key %]

[% END %] [% END %] [% END %] And you can also set messages configuration before. You can prepare configuration as hash reference. FormValidator::Simple->set_messages( { action1 => { name => { NOT_BLANK => 'input name!', LENGTH => 'input name (length should be between 0 and 10)!', }, email => { DEFAULT => 'input correct email address!', }, }, } ); or a YAML file. # messages.yml DEFAULT: name: DEFAULT: name is invalid! action1: name: NOT_BLANK: input name! LENGTH: input name(length should be between 0 and 10)! email: DEFAULT: input correct email address! action2: name: DEFAULT: ... # in your perl-script, set the file's path. FormValidator::Simple->set_messages('messages.yml'); DEFAULT is a special type. If it can't find setting for indicated validation-type, it uses message set for DEFAULT. after setting, execute check(), my $result = FormValidator::Simple->check( $q => [ name => [qw/NOT_BLANK/, [qw/LENGTH 0 10/] ], email => [qw/NOT_BLANK EMAIL_LOOSE/, [qw/LENGTH 0 20/] ], ] ); # matching result and messages for indicated action. my $messages = $result->messages('action1'); foreach my $message ( @$messages ) { print $message, "\n"; } # or you can get messages as hash style. # each fieldname is the key my $field_messages = $result->field_messages('action1'); if ($field_messages->{name}) { foreach my $message ( @{ $field_messages->{name} } ) { print $message, "\n"; } } When it can't find indicated action, name, and type, it searches proper message from DEFAULT action. If in template file, [% IF result.has_error %] [% FOREACH msg IN result.messages('action1') %]

[% msg %]

[% END %] [% END %] you can set each message format. FormValidator::Simple->set_message_format('

%s

'); my $result = FormValidator::Simple->check( $q => [ ...profile ] ); [% IF result.has_error %] [% result.messages('action1').join("\n") %] [% END %] =head1 RESULT HANDLING See L =head1 FLAGGED UTF-8 If you set encoding like follows, it automatically decode the result messages. FormValidtor::Simple->set_mesasges_decode_from('utf-8'); =head1 SEE ALSO L http://sl.edge.jp/ (Japanese) http://sourceforge.jp/projects/sledge =head1 AUTHOR Lyo Kato Elyo.kato@gmail.comE =head1 COPYRIGHT AND LICENSE This library is free software. You can redistribute it and/or modify it under the same terms as perl itself. =cut FormValidator-Simple-0.29/lib/FormValidator/Simple/ArrayList.pm000644 000765 000024 00000001314 11670056435 025317 0ustar00lyokatostaff000000 000000 package FormValidator::Simple::ArrayList; use strict; use base qw/Class::Accessor::Fast/; use FormValidator::Simple::Iterator; __PACKAGE__->mk_accessors(qw/records/); sub new { my $class = shift; my $self = bless { }, $class; $self->records( [ ] ); $self->_init(@_); return $self; } sub _init { my ($self, @args) = @_; } sub append { my ($self, $record) = @_; push @{ $self->records }, $record; } sub get_record_at { my ($self, $index) = @_; return $self->records->[$index]; } sub records_count { my $self = shift; return scalar @{ $self->records }; } sub iterator { my $self = shift; return FormValidator::Simple::Iterator->new($self); } 1; __END__ FormValidator-Simple-0.29/lib/FormValidator/Simple/Constants.pm000644 000765 000024 00000000331 11670056435 025357 0ustar00lyokatostaff000000 000000 package FormValidator::Simple::Constants; use strict; use base qw/Exporter/; our @EXPORT = qw/SUCCESS FAIL TRUE FALSE/; sub SUCCESS { 1 } sub FAIL { !SUCCESS } sub TRUE { 1 } sub FALSE { !TRUE } 1; __END__ FormValidator-Simple-0.29/lib/FormValidator/Simple/Constraint.pm000644 000765 000024 00000002431 11670056435 025532 0ustar00lyokatostaff000000 000000 package FormValidator::Simple::Constraint; use strict; use base qw/Class::Accessor::Fast/; use FormValidator::Simple::Exception; use FormValidator::Simple::Validator; use FormValidator::Simple::Constants; __PACKAGE__->mk_accessors(qw/name command negative args/); sub new { my $class = shift; my $self = bless { }, $class; $self->_init(@_); return $self; } sub _init { my ($self, $setting) = @_; if (ref $setting) { my($name, @args) = @$setting; $self->name($name); $self->args( [@args] ); } else { $self->name($setting); $self->args( [] ); } $self->_check_name; } sub _check_name { my $self = shift; my $name = $self->name; if($name =~ /^NOT_(.+)$/) { $self->command($1); $self->negative( TRUE ); } else { $self->command($name); $self->negative( FALSE ); } } sub check { my ($self, $params) = @_; my $command = $self->command; FormValidator::Simple::Exception->throw( qq/Unknown validation "$command"./ ) unless FormValidator::Simple::Validator->can($command); my ($result, $data) = FormValidator::Simple::Validator->$command($params, $self->args); $result = not $result if $self->negative; return ($result, $data); } 1; __END__ FormValidator-Simple-0.29/lib/FormValidator/Simple/Constraints.pm000644 000765 000024 00000001017 11670056435 025714 0ustar00lyokatostaff000000 000000 package FormValidator::Simple::Constraints; use strict; use base qw/FormValidator::Simple::ArrayList/; use FormValidator::Simple::Constants; use FormValidator::Simple::Iterator; __PACKAGE__->mk_accessors(qw/needs_blank_check/); sub _init { my $self = shift; $self->needs_blank_check( FALSE ); } sub iterator { my $self = shift; return FormValidator::Simple::Constraint::Iterator->new($self); } package FormValidator::Simple::Constraint::Iterator; use base qw/FormValidator::Simple::Iterator/; 1; __END__ FormValidator-Simple-0.29/lib/FormValidator/Simple/Data.pm000644 000765 000024 00000002332 11670056435 024257 0ustar00lyokatostaff000000 000000 package FormValidator::Simple::Data; use strict; use Scalar::Util; use FormValidator::Simple::Exception; use FormValidator::Simple::Constants; sub new { my $class = shift; my $self = bless { }, $class; $self->_init(@_); return $self; } sub _init { my ($self, $input) = @_; $self->{_records} = {}; my $errmsg = qq/Set input data as a hashref or object that has the method 'param()'./; if ( Scalar::Util::blessed($input) ) { unless ( $input->can('param') ) { FormValidator::Simple::Exception->throw($errmsg); } foreach my $key ( $input->param ) { my @v = $input->param($key); $self->{_records}{$key} = scalar(@v) > 1 ? \@v : $v[0]; } } elsif ( ref $input eq 'HASH' ) { $self->{_records} = $input; } else { FormValidator::Simple::Exception->throw($errmsg); } } sub has_key { my ($self, $key) = @_; return exists $self->{_records}{$key} ? TRUE : FALSE; } sub param { my ($self, $keys) = @_; my @values = map { exists $self->{_records}{$_} ? $self->{_records}{$_} : '' ; } @$keys; return wantarray ? @values : \@values; } 1; __END__ FormValidator-Simple-0.29/lib/FormValidator/Simple/Exception.pm000644 000765 000024 00000000226 11670056435 025344 0ustar00lyokatostaff000000 000000 package FormValidator::Simple::Exception; use strict; sub throw { my ($self, $msg) = @_; require Carp; Carp::croak($msg); } 1; __END__ FormValidator-Simple-0.29/lib/FormValidator/Simple/Iterator.pm000644 000765 000024 00000001065 11670056435 025201 0ustar00lyokatostaff000000 000000 package FormValidator::Simple::Iterator; use strict; sub new { my $class = shift; my $self = bless { }, $class; $self->_init(@_); return $self; } sub _init { my ($self, $records) = @_; $self->{_index} = 0; $self->{_records} = $records; } sub reset { my $self = shift; $self->{_index} = 0; } sub next { my $self = shift; return unless ($self->{_records}->records_count > $self->{_index}); my $record = $self->{_records}->get_record_at($self->{_index}); $self->{_index}++; return $record; } 1; __END__ FormValidator-Simple-0.29/lib/FormValidator/Simple/Messages.pm000644 000765 000024 00000005627 11670056435 025167 0ustar00lyokatostaff000000 000000 package FormValidator::Simple::Messages; use strict; use base 'Class::Accessor::Fast'; use YAML; use FormValidator::Simple::Exception; __PACKAGE__->mk_accessors(qw/decode_from/); use Encode; sub new { my $class = shift; my $self = bless { _data => undef, _format => "%s", }, $class; return $self; } sub format { my ($self, $format) = @_; if ($format) { $self->{_format} = $format; } $self->{_format}; } sub load { my ($self, $data) = @_; if (ref $data eq 'HASH') { $self->{_data} = $data; } elsif (-e $data && -f _ && -r _) { eval { $self->{_data} = YAML::LoadFile($data); }; if ($@) { FormValidator::Simple::Exception->throw( qq/failed to load YAML file. "$@"/ ); } } else { FormValidator::Simple::Exception->throw( qq/set hash reference or YAML file path./ ); } } sub get { my $self = shift; my $msg = $self->_get(@_); if ($self->decode_from && !Encode::is_utf8($msg)) { $msg = Encode::decode($self->decode_from, $msg); } return sprintf $self->format, $msg; } sub _get { my ($self, $action, $name, $type) = @_; my $data = $self->{_data}; unless ($data) { FormValidator::Simple::Exception->throw( qq/set messages before calling get()./ ); } unless ( $action && exists $data->{$action} ) { if ( exists $data->{DEFAULT} ) { if ( exists $data->{DEFAULT}{$name} ) { my $conf = $data->{DEFAULT}{$name}; if ( exists $conf->{$type} ) { return $conf->{$type}; } elsif ( exists $conf->{DEFAULT} ) { return $conf->{DEFAULT}; } } else { return "$name is invalid."; } } else { return "$name is invalid."; } } if ( exists $data->{$action}{$name} ) { my $conf = $data->{$action}{$name}; if ( exists $conf->{$type} ) { return $conf->{$type}; } elsif ( exists $conf->{DEFAULT} ) { return $conf->{DEFAULT}; } elsif ( exists $data->{DEFAULT} && exists $data->{DEFAULT}{$name} ) { my $conf = $data->{DEFAULT}{$name}; if ( exists $conf->{$type} ) { return $conf->{$type}; } elsif ( exists $conf->{DEFAULT} ) { return $conf->{DEFAULT}; } } } elsif ( exists $data->{DEFAULT} && exists $data->{DEFAULT}{$name} ) { my $conf = $data->{DEFAULT}{$name}; if ( exists $conf->{$type} ) { return $conf->{$type}; } elsif ( exists $conf->{DEFAULT} ) { return $conf->{DEFAULT}; } } return "$name is invalid."; } 1; __END__ FormValidator-Simple-0.29/lib/FormValidator/Simple/Profile.pm000644 000765 000024 00000005675 11670056435 025023 0ustar00lyokatostaff000000 000000 package FormValidator::Simple::Profile; use strict; use base qw/FormValidator::Simple::ArrayList/; use FormValidator::Simple::Exception; use FormValidator::Simple::Iterator; sub _init { my($self, $prof) = @_; for (my $i = 0; $i <= $#{$prof}; $i += 2) { my ($key, $constraints) = ($prof->[$i], $prof->[$i + 1]); my $record = FormValidator::Simple::Profile::Record->new; $record->set_keys($key); $record->set_constraints($constraints); $self->append($record); } } sub iterator { my $self = shift; return FormValidator::Simple::Profile::Iterator->new($self); } package FormValidator::Simple::Profile::Record; use base qw/Class::Accessor::Fast/; use FormValidator::Simple::Exception; use FormValidator::Simple::Constants; use FormValidator::Simple::Constraints; use FormValidator::Simple::Constraint; __PACKAGE__->mk_accessors(qw/name keys constraints/); sub new { my $class = shift; my $self = bless { }, $class; $self->_init(@_); return $self; } sub _init { my $self = shift; $self->name( q{ } ); $self->keys( [] ); $self->constraints( FormValidator::Simple::Constraints->new ); } sub set_keys { my ($self, $keys) = @_; if (ref $keys) { if (ref $keys eq 'HASH') { my ($name) = keys %$keys; my $params = $keys->{$name}; $self->name($name); if(ref $params) { $self->keys( $params ); } else { $self->keys( [$params] ); } } else { FormValidator::Simple::Exception->throw( qq/set keys of profile as hashref or single scalar./ ); } } else { $self->name( $keys ); $self->keys( [$keys] ); } } sub set_constraints { my ($self, $constraints) = @_; $self->constraints( FormValidator::Simple::Constraints->new ); if (ref $constraints) { if (ref $constraints eq 'ARRAY') { SETTING: foreach my $setting ( @$constraints ) { my $const = FormValidator::Simple::Constraint->new($setting); if ($const->name eq 'NOT_BLANK') { $self->constraints->needs_blank_check( TRUE ); next SETTING; } else { $self->constraints->append($const); } } } else { FormValidator::Simple::Exception->throw( qq/set constraints as arrayref or single scalar./ ); } } else { my $const = FormValidator::Simple::Constraint->new($constraints); if ($const->name eq 'NOT_BLANK') { $self->constraints->needs_blank_check( TRUE ); } else { $self->constraints->append($const); } } } package FormValidator::Simple::Profile::Iterator; use base qw/FormValidator::Simple::Iterator/; 1; __END__ FormValidator-Simple-0.29/lib/FormValidator/Simple/Result.pm000644 000765 000024 00000002666 11670056435 024676 0ustar00lyokatostaff000000 000000 package FormValidator::Simple::Result; use strict; use base qw/Class::Accessor::Fast/; use FormValidator::Simple::Constants; use FormValidator::Simple::Exception; use Tie::IxHash; __PACKAGE__->mk_accessors(qw/name constraints data is_blank/); sub new { my $class = shift; my $self = bless { }, $class; $self->_init(@_); return $self; } sub _init { my ($self, $name) = @_; my %constraints = (); tie (%constraints, 'Tie::IxHash'); $self->name($name); $self->constraints(\%constraints); $self->data(q{}); $self->is_blank( FALSE ); } sub set { my ($self, $constraint, $result) = @_; $self->constraints->{$constraint} = $result; } sub is_valid { my $self = shift; return FALSE if $self->is_blank; foreach my $result ( values %{ $self->constraints } ) { return FALSE unless $result; } return TRUE; } sub is_invalid { my $self = shift; return FALSE if $self->is_blank; foreach my $result ( values %{ $self->constraints } ) { return TRUE unless $result; } return FALSE; } sub is_valid_for { my ($self, $constraint) = @_; return TRUE unless exists $self->constraints->{$constraint}; return $self->constraints->{$constraint} ? TRUE : FALSE; } sub is_invalid_for { my ($self, $constraint) = @_; return FALSE unless exists $self->constraints->{$constraint}; return $self->constraints->{$constraint} ? FALSE : TRUE; } 1; __END__ FormValidator-Simple-0.29/lib/FormValidator/Simple/Results.pm000644 000765 000024 00000021104 11670056435 025045 0ustar00lyokatostaff000000 000000 package FormValidator::Simple::Results; use strict; use base qw/Class::Accessor::Fast/; use FormValidator::Simple::Result; use FormValidator::Simple::Exception; use FormValidator::Simple::Constants; use Tie::IxHash; use List::MoreUtils; __PACKAGE__->mk_accessors(qw/_records message/); sub new { my $class = shift; my $self = bless { }, $class; $self->_init(@_); return $self; } sub _init { my ($self, %args) = @_; my %hash = (); tie (%hash, 'Tie::IxHash'); $self->_records(\%hash); my $messages = delete $args{messages}; $self->message($messages); } sub messages { my ($self, $action) = @_; my @messages = (); my $keys = $self->error; foreach my $key ( @$keys ) { my $types = $self->error($key); foreach my $type ( @$types ) { push @messages, $self->message->get($action, $key, $type); } } @messages = List::MoreUtils::uniq(@messages); return \@messages; } sub field_messages { my ($self, $action) = @_; my $messages = {}; my $keys = $self->error; foreach my $key ( @$keys ) { $messages->{$key} = []; my $types = $self->error($key); foreach my $type ( @$types ) { my $message = $self->message->get($action, $key, $type); unless ( List::MoreUtils::any { $_ eq $message } @{ $messages->{$key} } ) { push @{ $messages->{$key} }, $message; } } } return $messages; } sub register { my ($self, $name) = @_; $self->_records->{$name} ||= FormValidator::Simple::Result->new($name); } sub record { my ($self, $name) = @_; $self->register($name) unless exists $self->_records->{$name}; return $self->_records->{$name}; } sub set_result { my ($self, $name, $type, $result) = @_; $self->register($name); $self->record($name)->set($type, $result); } sub set_invalid { my ($self, $name, $type) = @_; unless ($name && $type) { FormValidator::Simple::Exception->throw( qq/set_invalid needs two arguments./ ); } $self->set_result($name, $type, FALSE); } sub success { my $self = shift; return ($self->has_missing or $self->has_invalid) ? FALSE : TRUE; } sub has_error { my $self = shift; return ($self->has_missing or $self->has_invalid) ? TRUE : FALSE; } sub has_blank { my $self = shift; foreach my $record ( values %{ $self->_records } ) { return TRUE if $record->is_blank; } return FALSE; } *has_missing = \&has_blank; sub has_invalid { my $self = shift; foreach my $record ( values %{ $self->_records } ) { return TRUE if $record->is_invalid; } return FALSE; } sub valid { my ($self, $name) = @_; if ($name) { return unless exists $self->_records->{$name}; return $self->record($name)->is_valid ? $self->record($name)->data : FALSE; } else { my %valids = map { ( $_->name, $_->data ) } grep { $_->is_valid } values %{ $self->_records }; return \%valids; } } sub error { my ($self, $name, $constraint) = @_; if ($name) { if ($constraint) { if ($constraint eq 'NOT_BLANK') { return $self->record($name)->is_blank ? TRUE : FALSE ; } return $self->record($name)->is_invalid_for($constraint) ? TRUE : FALSE ; } else { if ($self->record($name)->is_blank) { return wantarray ? 'NOT_BLANK' : ['NOT_BLANK']; } elsif ($self->record($name)->is_invalid) { my $constraints = $self->record($name)->constraints; my @invalids = grep { !$constraints->{$_} } keys %$constraints; return wantarray ? @invalids : \@invalids; } else { return FALSE; } } } else { my @errors = map { $_->name } grep { $_->is_blank or $_->is_invalid } values %{ $self->_records }; return wantarray ? @errors : \@errors; } } sub blank { my ($self, $name) = @_; if ($name) { return $self->record($name)->is_blank ? TRUE : FALSE; } else { my @blanks = map { $_->name } grep { $_->is_blank } values %{ $self->_records }; return wantarray ? @blanks : \@blanks; } } *missing = \␣ sub invalid { my ($self, $name, $constraint) = @_; if ($name) { if ($constraint) { $self->record($name)->is_invalid_for($constraint) ? TRUE : FALSE; } else { if ($self->record($name)->is_invalid) { my $constraints = $self->record($name)->constraints; my @invalids = grep { !$constraints->{$_} } keys %$constraints; return wantarray ? @invalids : \@invalids; } else { return FALSE; } } } else { my @invalids = map { $_->name } grep { $_->is_invalid } values %{ $self->_records }; return wantarray ? @invalids : \@invalids; } } sub clear { %{shift->_records} = (); } 1; __END__ =head1 NAME FormValidator::Simple::Results - results of validation =head1 SYNOPSIS my $results = FormValidator::Simple->check( $req => [ name => [qw/NOT_BLANK ASCII/, [qw/LENGTH 0 10/] ], email => [qw/NOT_BLANK EMAIL_LOOSE/, [qw/LENGTH 0 30/] ], ] ); if ( $results->has_error ) { foreach my $key ( @{ $results->error() } ) { foreach my $type ( @{ $results->erorr($key) } ) { print "invalid: $key - $type \n"; } } } =head1 DESCRIPTION This is for handling resuls of FormValidator::Simple's check. This object behaves like Data::FormValidator's results object, but has some specific methods. =head1 CHECK RESULT =over 4 =item has_missing If there are missing values ( failed in validation 'NOT_BLANK' ), this method returns true. if ( $results->has_missing ) { ... } =item has_invalid If there are invalid values ( failed in some validations except 'NOT_BLANK' ), this method returns true. if ( $results->has_invalid ) { ... } =item has_error If there are missing or invalid values, this method returns true. if ( $results->has_error ) { ... } =item success inverse of has_error unless ( $resuls->success ) { ... } =back =head1 ANALYZING RESULTS =head2 missing =over 4 =item no argument When you call this method with no argument, it returns keys failed 'NOT_BLANK' validation. my $missings = $results->missing; foreach my $missing_data ( @$missings ) { print $missing_data, "\n"; } # -- print out, for example -- # name # email =item key When you call this method with key-name, it returnes true if the value of the key is missing. if ( $results->missing('name') ) { print "name is empty! \n"; } =back =head2 invalid =over 4 =item no argument When you call this method with no argument, it returns keys that failed some validation except 'NOT_BLANK'. my $invalids = $results->invalid; foreach my $invalid_data ( @$invalids ) { print $invalid_data, "\n"; } # -- print out, for example -- # name # email =item key When you call this method with key-name, it returns names of failed validation. my $failed_validations = $results->invalid('name'); foreach my $validation ( @$failed_validations ) { print $validation, "\n"; } # -- print out, for example -- # ASCII # LENGTH =item key and validation-name When you call this method with key-name, it returns false if the value has passed the validation. if ( $results->invalid( name => 'LENGTH' ) ) { print "name is wrong length! \n"; } =back =head2 error This doesn't distinguish 'missing' and 'invalid'. You can use this like 'invalid' method, but this consider 'NOT_BLANK' same as other validations. my $error_keys = $results->error; my $failed_validation = $resuls->error('name'); # this includes 'NOT_BLANK' if ( $results->error( name => 'NOT_BLANK' ) ) { print "name is missing! \n"; } if ( $results->error( name => 'ASCII' ) ) { print "name should be ascii code! \n"; } =head1 SEE ALSO L =head1 AUTHOR Lyo Kato Elyo.kato@gmail.comE =head1 COPYRIGHT AND LICENSE This library is free software. You can redistribute it and/or modify it under the same terms as perl itself. =cut FormValidator-Simple-0.29/lib/FormValidator/Simple/Validator.pm000644 000765 000024 00000025061 11670056435 025337 0ustar00lyokatostaff000000 000000 package FormValidator::Simple::Validator; use strict; use base qw/Class::Data::Inheritable/; use FormValidator::Simple::Constants; use FormValidator::Simple::Exception; use Email::Valid; use Email::Valid::Loose; use Date::Calc; use UNIVERSAL::require; use List::MoreUtils; use DateTime::Format::Strptime; __PACKAGE__->mk_classdata( options => { } ); sub SP { my ($self, $params, $args) = @_; my $data = $params->[0]; return $data =~ /\s/ ? TRUE : FALSE; } *SPACE = \&SP; sub INT { my ($self, $params, $args) = @_; my $data = $params->[0]; return $data =~ /^\-?[\d]+$/ ? TRUE : FALSE; } sub UINT { my ($self, $params, $args) = @_; my $data = $params->[0]; return $data =~ /^\d+$/ ? TRUE : FALSE; } sub ASCII { my ($self, $params, $args) = @_; my $data = $params->[0]; return $data =~ /^[\x21-\x7E]+$/ ? TRUE : FALSE; } sub DUPLICATION { my ($self, $params, $args) = @_; my $data1 = $params->[0]; my $data2 = $params->[1]; unless (defined $data1 && defined $data2) { FormValidator::Simple::Exception->throw( qq/validation "DUPLICATION" needs two keys of data./ ); } return $data1 eq $data2 ? TRUE : FALSE; } sub LENGTH { my ($self, $params, $args) = @_; unless ( scalar(@$args) > 0 ) { FormValidator::Simple::Exception->throw( qq/validation "LENGTH" needs one or two arguments./ ); } my $data = $params->[0]; my $length = length $data; my $min = $args->[0]; my $max = $args->[1] || $min; $min += 0; $max += 0; return $min <= $length && $length <= $max ? TRUE : FALSE; } sub REGEX { my ($self, $params, $args) = @_; my $data = $params->[0]; my $regex = $args->[0]; return $data =~ /$regex/ ? TRUE : FALSE; } sub EMAIL { my ($self, $params, $args) = @_; my $data = $params->[0]; return FALSE unless $data; return Email::Valid->address(-address => $data) ? TRUE : FALSE; } sub EMAIL_MX { my ($self, $params, $args) = @_; my $data = $params->[0]; return FALSE unless $data; return Email::Valid->address(-address => $data, -mxcheck => 1) ? TRUE : FALSE; } sub EMAIL_LOOSE { my ($self, $params, $args) = @_; my $data = $params->[0]; return FALSE unless $data; return Email::Valid::Loose->address($data) ? TRUE : FALSE; } sub EMAIL_LOOSE_MX { my ($self, $params, $args) = @_; my $data = $params->[0]; return FALSE unless $data; return Email::Valid::Loose->address(-address => $data, -mxcheck => 1) ? TRUE : FALSE; } sub DATE { my ($self, $params, $args) = @_; my ($year, $month, $day ) = @$params; my $result = Date::Calc::check_date($year, $month, $day) ? TRUE : FALSE; my $data; if ($result) { my $class = $self->options->{datetime_class} || ''; if ($class eq 'DateTime') { $class->require; if ($@) { FormValidator::Simple::Exception->throw( qq/Validation DATE: failed to require $class. "$@"./ ); } my %date = ( year => $year, month => $month, day => $day, ); if ($self->options->{time_zone}) { $date{time_zone} = $self->options->{time_zone}; } $data = $class->new(%date); } elsif ($class eq 'Time::Piece') { $data = sprintf "%04d-%02d-%02d 00:00:00", $year, $month, $day; $class->require; if ($@) { FormValidator::Simple::Exception->throw( qq/Validation DATE: failed to require $class. "$@"./ ); } $data = $class->strptime($data, "%Y-%m-%d %H:%M:%S"); } else { $data = sprintf "%04d-%02d-%02d 00:00:00", $year, $month, $day; } } return ($result, $data); } sub TIME { my ($self, $params, $args) = @_; my ($hour, $min, $sec ) = @$params; $hour ||= 0; $min ||= 0; $sec ||= 0; my $result = Date::Calc::check_time($hour, $min, $sec) ? TRUE : FALSE; my $time = $result ? sprintf("%02d:%02d:%02d", $hour, $min, $sec) : undef; return ($result, $time); } sub DATETIME { my ($self, $params, $args) = @_; my ($year, $month, $day, $hour, $min, $sec) = @$params; $hour ||= 0; $min ||= 0; $sec ||= 0; my $result = Date::Calc::check_date($year, $month, $day) && Date::Calc::check_time($hour, $min, $sec) ? TRUE : FALSE; my $data; if ($result) { my $class = $self->options->{datetime_class} || ''; if ($class eq 'DateTime') { $class->require; if ($@) { FormValidator::Simple::Exception->throw( qq/Validation DATETIME: failed to require $class. "$@"./ ); } my %date = ( year => $year, month => $month, day => $day, hour => $hour, minute => $min, second => $sec, ); if ($self->options->{time_zone}) { $date{time_zone} = $self->options->{time_zone}; } $data = $class->new(%date); } elsif ($class eq 'Time::Piece') { $data = sprintf "%04d-%02d-%02d %02d:%02d:%02d", $year, $month, $day, $hour, $min, $sec; $class->require; if ($@) { FormValidator::Simple::Exception->throw( qq/Validation DATETIME: failed to require $class. "$@"./ ); } $data = $class->strptime($data, "%Y-%m-%d %H:%M:%S"); } else { $data = sprintf "%04d-%02d-%02d %02d:%02d:%02d", $year, $month, $day, $hour, $min, $sec; } } return ($result, $data); } sub ANY { my ($self, $params, $args) = @_; foreach my $param ( @$params ) { return TRUE if ( defined $param && $param ne '' ); } return FALSE; } sub HTTP_URL { my ($self, $params, $args) = @_; my $data = $params->[0]; return $data =~ /^s?https?:\/\/[-_.!~*'()a-zA-Z0-9;\/?:\@&=+\$,%#]+$/ ? TRUE : FALSE; } sub SELECTED_AT_LEAST { my ($self, $params, $args) = @_; my $data = $params->[0]; my $selected = ref $data ? $data : [$data]; my $num = $args->[0] + 0; return scalar(@$selected) >= $num ? TRUE : FALSE; } sub GREATER_THAN { my ($self, $params, $args) = @_; my $data = $params->[0]; my $target = $args->[0]; my $regex = qr/^[-+]?[0-9]+(:?\.[0-9]+)?$/; unless ( defined $target && $target =~ /$regex/ ) { FormValidator::Simple::Exception->throw( qq/Validation GREATER_THAN needs a numeric argument./ ); } return FALSE unless $data =~ /$regex/; return ( $data > $target ) ? TRUE : FALSE; } sub LESS_THAN { my ($self, $params, $args) = @_; my $data = $params->[0]; my $target = $args->[0]; my $regex = qr/^[-+]?[0-9]+(:?\.[0-9]+)?$/; unless ( defined $target && $target =~ /$regex/ ) { FormValidator::Simple::Exception->throw( qq/Validation LESS_THAN needs a numeric argument./ ); } return FALSE unless $data =~ /$regex/; return ( $data < $target ) ? TRUE : FALSE; } sub EQUAL_TO { my ($self, $params, $args) = @_; my $data = $params->[0]; my $target = $args->[0]; my $regex = qr/^[-+]?[0-9]+(:?\.[0-9]+)?$/; unless ( defined $target && $target =~ /$regex/ ) { FormValidator::Simple::Exception->throw( qq/Validation EQUAL_TO needs a numeric argument./ ); } return FALSE unless $data =~ /$regex/; return ( $data == $target ) ? TRUE : FALSE; } sub BETWEEN { my ($self, $params, $args) = @_; my $data = $params->[0]; my $start = $args->[0]; my $end = $args->[1]; my $regex = qr/^[-+]?[0-9]+(:?\.[0-9]+)?$/; unless ( defined($start) && $start =~ /$regex/ && defined($end) && $end =~ /$regex/ ) { FormValidator::Simple::Exception->throw( qq/Validation BETWEEN needs two numeric arguments./ ); } return FALSE unless $data =~ /$regex/; return ( $data >= $start && $data <= $end ) ? TRUE : FALSE; } sub DECIMAL { my ($self, $params, $args) = @_; my $data = $params->[0]; unless ( scalar(@$args) > 0 ) { FormValidator::Simple::Exception->throw( qq/Validation DECIMAL needs one or two numeric arguments./ ); } my $digit1 = $args->[0]; my $digit2 = $args->[1] || 0; unless ( $digit1 =~ /^\d+$/ && $digit2 =~ /^\d+$/ ) { FormValidator::Simple::Exception->throw( qq/Validation DECIMAL needs one or two numeric arguments./ ); } return FALSE unless $data =~ /^\d+(\.\d+)?$/; my $reg = qr/^\d{1,$digit1}(\.\d{0,$digit2})?$/; return $data =~ /$reg/ ? TRUE : FALSE; } sub ALL { my ($self, $params, $args) = @_; foreach my $param ( @$params ) { unless ( defined $param && $param ne '' ) { return FALSE; } } return TRUE; } sub IN_ARRAY { my ($class, $params, $args) = @_; my $data = defined $params->[0] ? $params->[0] : ''; return (List::MoreUtils::any { $_ eq $data } @$args) ? TRUE : FALSE; } sub DATETIME_FORMAT { my ( $self, $params, $args ) = @_; my $date = $params->[0]; my $format = $args->[0]; FormValidator::Simple::Exception->throw( qq/Validation DATETIME_FORMAT needs a format argument./) unless $format; my $module; if ( ref $format ) { $module = $format; } else { $module = "DateTime::Format::$format"; $module->require or FormValidator::Simple::Exception->throw( qq/Validation DATETIME_FORMAT: failed to require $module. "$@"/ ); } my $dt; eval { $dt = $module->parse_datetime($date); }; my $result = $dt ? TRUE : FALSE; if ( $dt && $self->options->{time_zone} ) { $dt->set_time_zone( $self->options->{time_zone} ); } return ($result, $dt); } sub DATETIME_STRPTIME { my ( $self, $params, $args ) = @_; my $date = $params->[0]; my $format = $args->[0]; FormValidator::Simple::Exception->throw( qq/Validation DATETIME_STRPTIME needs a format argument./) unless $format; my $dt; eval{ my $strp = DateTime::Format::Strptime->new( pattern => $format, on_error => 'croak' ); $dt = $strp->parse_datetime($date); }; my $result = $dt ? TRUE : FALSE; if ( $dt && $self->options->{time_zone} ) { $dt->set_time_zone( $self->options->{time_zone} ); } return ($result, $dt); } 1; __END__ FormValidator-Simple-0.29/inc/Module/000755 000765 000024 00000000000 11670057572 020301 5ustar00lyokatostaff000000 000000 FormValidator-Simple-0.29/inc/Module/AutoInstall.pm000644 000765 000024 00000054231 11670057571 023102 0ustar00lyokatostaff000000 000000 #line 1 package Module::AutoInstall; use strict; use Cwd (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.03'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps ); my ( $PostambleActions, $PostambleUsed ); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::cwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. my $cur = _load($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { if (not defined $cur) # indeed missing { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; } else { # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above print "too old. ($cur < $arg)\n"; } push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) { require Config; print "*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n"; # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; return (@Existing, @Missing); } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89') { if ($cpan_env) { return _running_under('CPAN'); } return; # CPAN.pm new enough, don't need to check further } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed ); while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) { # grep out those already installed if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { push @installed, $pkg; } else { push @modules, $pkg, $ver; } } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^force$/; # pseudo-option $CPAN::Config->{$opt} = $arg; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $args{force} ? CPAN::Shell->force( install => $pkg ) : CPAN::Shell->install($pkg); $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::cwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # class/instance doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to # CPAN::HandleConfig->load. CPAN reports that the redirection # is deprecated in a warning printed at the user. # CPAN-1.81 expects CPAN::HandleConfig->load, does not have # $CPAN::HandleConfig::VERSION but cannot handle # CPAN::Config->load # Which "versions expect CPAN::Config->load? if ( $CPAN::HandleConfig::VERSION || CPAN::HandleConfig->can('load') ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison # return values same as <=> sub _version_cmp { my ( $cur, $min ) = @_; return -1 unless defined $cur; # if 0 keep comparing return 1 unless $min; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return version->new($cur) <=> version->new($min); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return Sort::Versions::versioncmp( $cur, $min ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return $cur <=> $min; } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; return <<"END_MAKE"; config :: installdeps \t\$(NOECHO) \$(NOOP) checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions END_MAKE } 1; __END__ #line 1071 FormValidator-Simple-0.29/inc/Module/Install/000755 000765 000024 00000000000 11670057572 021707 5ustar00lyokatostaff000000 000000 FormValidator-Simple-0.29/inc/Module/Install.pm000644 000765 000024 00000030135 11670057571 022246 0ustar00lyokatostaff000000 000000 #line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.00'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2010 Adam Kennedy. FormValidator-Simple-0.29/inc/Module/Install/AutoInstall.pm000644 000765 000024 00000003632 11670057571 024507 0ustar00lyokatostaff000000 000000 #line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub AutoInstall { $_[0] } sub run { my $self = shift; $self->auto_install_now(@_); } sub write { my $self = shift; $self->auto_install(@_); } sub auto_install { my $self = shift; return if $self->{done}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; my @config = @_; # We'll need Module::AutoInstall $self->include('Module::AutoInstall'); require Module::AutoInstall; my @features_require = Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); my %seen; my @requires = map @$_, map @$_, grep ref, $self->requires; while (my ($mod, $ver) = splice(@requires, 0, 2)) { $seen{$mod}{$ver}++; } my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @deduped; while (my ($mod, $ver) = splice(@features_require, 0, 2)) { push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; } $self->requires(@deduped); $self->makemaker_args( Module::AutoInstall::_make_args() ); my $class = ref($self); $self->postamble( "# --- $class section:\n" . Module::AutoInstall::postamble() ); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; FormValidator-Simple-0.29/inc/Module/Install/Base.pm000644 000765 000024 00000002147 11670057571 023122 0ustar00lyokatostaff000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.00'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 FormValidator-Simple-0.29/inc/Module/Install/Can.pm000644 000765 000024 00000003333 11670057572 022750 0ustar00lyokatostaff000000 000000 #line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 FormValidator-Simple-0.29/inc/Module/Install/Fetch.pm000644 000765 000024 00000004627 11670057572 023307 0ustar00lyokatostaff000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; FormValidator-Simple-0.29/inc/Module/Install/Include.pm000644 000765 000024 00000001015 11670057571 023624 0ustar00lyokatostaff000000 000000 #line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; FormValidator-Simple-0.29/inc/Module/Install/Makefile.pm000644 000765 000024 00000027032 11670057571 023765 0ustar00lyokatostaff000000 000000 #line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT $DB::single = 1; if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 541 FormValidator-Simple-0.29/inc/Module/Install/Metadata.pm000644 000765 000024 00000043020 11670057571 023763 0ustar00lyokatostaff000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( \Qhttp://rt.cpan.org/\E[^>]+| \Qhttp://github.com/\E[\w_]+/[\w_]+/issues| \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; FormValidator-Simple-0.29/inc/Module/Install/Win32.pm000644 000765 000024 00000003403 11670057572 023147 0ustar00lyokatostaff000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; FormValidator-Simple-0.29/inc/Module/Install/WriteAll.pm000644 000765 000024 00000002376 11670057572 024000 0ustar00lyokatostaff000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1;