DBIx-Class-EncodedColumn-0.00015/000755 001757 001762 00000000000 12723565154 016575 5ustar00wreiswreis000000 000000 DBIx-Class-EncodedColumn-0.00015/lib/000755 001757 001762 00000000000 12723565154 017343 5ustar00wreiswreis000000 000000 DBIx-Class-EncodedColumn-0.00015/META.yml000644 001757 001762 00000001474 12723565147 020056 0ustar00wreiswreis000000 000000 --- abstract: 'Automatically encode column values' author: - 'Guillermo Roditi (groditi) ' build_requires: DBD::SQLite: 0 Dir::Self: 0 ExtUtils::MakeMaker: 6.36 File::Spec: 0 File::Temp: 0 Test::More: 0 configure_requires: ExtUtils::MakeMaker: 6.36 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.16' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: DBIx-Class-EncodedColumn no_index: directory: - inc - t recommends: Crypt::OpenPGP: 0 Digest: 0 Digest::SHA: 0 Math::Pari: 0 requires: DBIx::Class: '0.06002' Encode: 0 Sub::Name: '0.04' resources: license: http://dev.perl.org/licenses/ repository: git://github.com/wreis/DBIx-Class-EncodedColumn.git version: '0.00015' DBIx-Class-EncodedColumn-0.00015/inc/000755 001757 001762 00000000000 12723565154 017346 5ustar00wreiswreis000000 000000 DBIx-Class-EncodedColumn-0.00015/MANIFEST000644 001757 001762 00000002431 12723565152 017724 0ustar00wreiswreis000000 000000 Changes inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AuthorRequires.pm inc/Module/Install/AuthorTests.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/ReadmeFromPod.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/DBIx/Class/EncodedColumn.pm lib/DBIx/Class/EncodedColumn/Crypt.pm lib/DBIx/Class/EncodedColumn/Crypt/Eksblowfish/Bcrypt.pm lib/DBIx/Class/EncodedColumn/Crypt/OpenPGP.pm lib/DBIx/Class/EncodedColumn/Digest.pm Makefile.PL MANIFEST This list of files META.yml README t/bcrypt.t t/class_level_encoders.t t/crypt.t t/digest_sha.t t/lib/DigestTest/Schema.pm t/lib/DigestTest/Schema/Bcrypt.pm t/lib/DigestTest/Schema/PGP.pm t/lib/DigestTest/Schema/pubring.gpg t/lib/DigestTest/Schema/secring.gpg t/lib/DigestTest/Schema/SHA.pm t/lib/DigestTest/Schema/Whirlpool.pm t/lib/DigestTest/Schema/WithTimeStamp.pm t/lib/DigestTest/Schema/WithTimeStampChild.pm t/lib/DigestTest/Schema/WithTimeStampChildWrongOrder.pm t/lib/DigestTest/Schema/WithTimeStampParent.pm t/lib/DigestTest/Schema/WithTimeStampParentWrongOrder.pm t/open_pgp.t t/var/DigestTest-Schema-1.x-SQLite.sql t/whirlpool.t DBIx-Class-EncodedColumn-0.00015/README000644 001757 001762 00000013651 12723565147 017465 0ustar00wreiswreis000000 000000 NAME DBIx::Class::EncodedColumn - Automatically encode columns SYNOPSIS In your DBIx::Class Result class (sometimes erroneously referred to as the 'table' class): __PACKAGE__->load_components(qw/EncodedColumn ... Core/); #Digest encoder with hex format and SHA-1 algorithm __PACKAGE__->add_columns( 'password' => { data_type => 'CHAR', size => 40, encode_column => 1, encode_class => 'Digest', encode_args => {algorithm => 'SHA-1', format => 'hex'}, } #SHA-1 / hex encoding / generate check method __PACKAGE__->add_columns( 'password' => { data_type => 'CHAR', size => 40 + 10, encode_column => 1, encode_class => 'Digest', encode_args => {algorithm => 'SHA-1', format => 'hex', salt_length => 10}, encode_check_method => 'check_password', } #MD5 / base64 encoding / generate check method __PACKAGE__->add_columns( 'password' => { data_type => 'CHAR', size => 22, encode_column => 1, encode_class => 'Digest', encode_args => {algorithm => 'MD5', format => 'base64'}, encode_check_method => 'check_password', } #Eksblowfish bcrypt / cost of 8/ no key_nul / generate check method __PACKAGE__->add_columns( 'password' => { data_type => 'CHAR', size => 59, encode_column => 1, encode_class => 'Crypt::Eksblowfish::Bcrypt', encode_args => { key_nul => 0, cost => 8 }, encode_check_method => 'check_password', } In your application code: #updating the value. $row->password('plaintext'); my $digest = $row->password; #checking against an existing value with a check_method $row->check_password('old_password'); #true $row->password('new_password'); $row->check_password('new_password'); #returns true $row->check_password('old_password'); #returns false Note: The component needs to be loaded *before* Core and other components such as Timestamp. Core should always be last. E.g: __PACKAGE__->load_components(qw/EncodedColumn TimeStamp Core/); DESCRIPTION This DBIx::Class component can be used to automatically encode a column's contents whenever the value of that column is set. This module is similar to the existing DBIx::Class::DigestColumns, but there is some key differences: "DigestColumns" performs the encode operation on "insert" and "update", and "EncodedColumn" performs the operation when the value is set, or on "new". "DigestColumns" supports only algorithms of the Digest family. "EncodedColumn" employs a set of thin wrappers around different cipher modules to provide support for any cipher you wish to use and wrappers are very simple to write (typically less than 30 lines). "EncodedColumn" supports having more than one encoded column per table and each column can use a different cipher. "Encode" adds only one item to the namespace of the object utilizing it ("_column_encoders"). There is, unfortunately, some features that "EncodedColumn" doesn't support. "DigestColumns" supports changing certain options at runtime, as well as the option to not automatically encode values on set. The author of this module found these options to be non-essential and omitted them by design. Options added to add_column If any one of these options is present the column will be treated as a digest column and all of the defaults will be applied to the rest of the options. encode_enable => 1 Enable automatic encoding of column values. If this option is not set to true any other options will become no-ops. encode_check_method => $method_name By using the encode_check_method attribute when you declare a column you can create a check method for that column. The check method accepts a plain text string, and returns a boolean that indicates whether the digest of the provided value matches the current value. encode_class The class to use for encoding. Available classes are: "Crypt::Eksblowfish::Bcrypt" - uses DBIx::Class::EncodedColumn::Crypt::Eksblowfish::Bcrypt and requires Crypt::Eksblowfish::Bcrypt to be installed "Digest" - uses DBIx::Class::EncodedColumn::Digest requires Digest to be installed as well as the algorithm required (Digest::SHA, Digest::Whirlpool, etc) "Crypt::OpenPGP" - DBIx::Class::EncodedColumn::Crypt::OpenPGP and requires Crypt::OpenPGP to be installed Please see the relevant class's documentation for information about the specific arguments accepted by each and make sure you include the encoding algorithm (e.g. Crypt::OpenPGP) in your application's requirements. EXTENDED METHODS The following DBIx::Class::ResultSource method is extended: register_column - Handle the options described above. The following DBIx::Class::Row methods are extended by this module: new - Encode the columns on new() so that copy and create DWIM. set_column - Encode values whenever column is set. SEE ALSO DBIx::Class::DigestColumns, DBIx::Class, Digest AUTHOR Guillermo Roditi (groditi) Inspired by the original module written by Tom Kirkpatrick (tkp) featuring contributions from Guillermo Roditi (groditi) and Marc Mims CONTRIBUTORS jshirley - J. Shirley kentnl - Kent Fredric mst - Matt S Trout wreis - Wallace reis COPYRIGHT Copyright (c) the DBIx::Class::EncodedColumn "AUTHOR" and "CONTRIBUTORS" as listed above. LICENSE This library is free software and may be distributed under the same terms as perl itself. DBIx-Class-EncodedColumn-0.00015/Makefile.PL000644 001757 001762 00000001725 12723307561 020550 0ustar00wreiswreis000000 000000 #! /usr/bin/perl -w # Load the Module::Install bundled in ./inc/ use inc::Module::Install; use Module::Install::ReadmeFromPod; use Module::Install::AuthorTests; use Module::Install::AuthorRequires; # Define metadata name 'DBIx-Class-EncodedColumn'; abstract "Automatically encode column values"; all_from 'lib/DBIx/Class/EncodedColumn.pm'; readme_from; repository 'git://github.com/wreis/DBIx-Class-EncodedColumn.git'; # Specific dependencies requires 'DBIx::Class' => '0.06002'; requires 'Sub::Name' => '0.04'; requires 'Encode'; #build dependencies test_requires 'Test::More'; test_requires 'DBD::SQLite'; test_requires 'Dir::Self'; test_requires 'File::Temp'; test_requires 'File::Spec'; author_tests('t/author'); author_requires 'Crypt::Eksblowfish::Bcrypt'; author_requires 'DBIx::Class::TimeStamp'; recommends 'Digest'; recommends 'Digest::SHA'; recommends 'Crypt::OpenPGP'; # TODO: remove once Crypt::OpenPGP is fixed recommends 'Math::Pari'; auto_install; WriteAll; DBIx-Class-EncodedColumn-0.00015/Changes000644 001757 001762 00000003222 12723565004 020061 0ustar00wreiswreis000000 000000 0.00015 2016-06-01 - Build fixes 0.00014 2016-05-31 - prevent warning in ::Bcrypt when password is undef - Allow users to specify the Cipher used when encoding 0.00013 2014-02-27 - Pod fixes (RT#88875) - Fix deps (github#1) 0.00012 2013-04-29 - Fixes reported bug #78091. (gbjk++) 0.00011 2011-04-11 - Docs fixes 0.00010 2010-08-27 - Support for crypt() 0.00009 2010-05-17 - Rewritten test suite 0.00008 2010-04-30 - Fix packaging bug. 0.00007 2010-04-29 - Fix for inter-component leaks because of improper mk_classdata usage (fixes RT #5099 by Kent Fredric) ( groditi ) 0.00006 2010-01-15 - Fix build_requires version number for SQLA ( Arthur Axel "fREW" Schmidt ) - Don't encode undef ( osfameron ) 0.00005 2009-10-11 - Fix hashing/validation with Whirlpool ( Kent Fredric ) - Add Repository META 0.00004 2009-09-03 - correct option name typo in the docs (digest_class -> encode_class) - put the .gpg files back into the test so tests pass (mst == fool) 0.00003 2009-09-01 - fixup copyright and licensing info to the proposed new best practice for /^DBIx::Class/ modules - close dbh before unlinking so tests pass on win32 0.00002 2008-07-27 - Support for Crypt::OpenPGP 0.00001 2008-02-01 - No changes 0.00001_03 2008-01-31 - Pod Changes and corrections - Added common digest lengths table 0.00001_02 2008-01-31 -salt additions & little fixes 0.00001_01 2008-01-29 - Initial release DBIx-Class-EncodedColumn-0.00015/t/000755 001757 001762 00000000000 12723565154 017040 5ustar00wreiswreis000000 000000 DBIx-Class-EncodedColumn-0.00015/t/digest_sha.t000644 001757 001762 00000006523 12723307561 021341 0ustar00wreiswreis000000 000000 use strict; use warnings; use Test::More; use Dir::Self; use File::Spec; use File::Temp 'tempdir'; use lib File::Spec->catdir(__DIR__, 'lib'); use DigestTest::Schema; BEGIN { if( eval 'require Digest' && eval 'require Digest::SHA' ){ plan tests => 25; } else { plan skip_all => 'Digest::SHA not available'; exit; } } DigestTest::Schema->load_classes('SHA'); my $tmp = tempdir( CLEANUP => 1 ); my $db_file = File::Spec->catfile($tmp, 'testdb.sqlite'); my $schema = DigestTest::Schema->connect("dbi:SQLite:dbname=${db_file}"); $schema->deploy({}, File::Spec->catdir(__DIR__, 'var')); my $checks = {}; for my $algorithm( qw/SHA-1 SHA-256/){ my $maker = Digest->new($algorithm); my $encodings = $checks->{$algorithm} = {}; for my $encoding (qw/base64 hex/){ my $values = $encodings->{$encoding} = {}; my $encoding_method = $encoding eq 'binary' ? 'digest' : ($encoding eq 'hex' ? 'hexdigest' : 'b64digest'); for my $value (qw/test1 test2/){ $maker->add($value); $values->{$value} = $maker->$encoding_method; } } } my %create_values = map { $_ => 'test1' } qw( dummy_col sha1_hex sha1_b64 sha256_hex sha256_b64 sha256_b64_salted ); my $row = $schema->resultset('SHA')->create( \%create_values ); is($row->dummy_col, 'test1','dummy on create'); ok(!$row->can('check_dummy_col'), 'no "check_dummy_col" method'); is($row->sha1_hex, $checks->{'SHA-1'}{hex}{test1}, 'hex sha1 on create'); is($row->sha1_b64, $checks->{'SHA-1'}{base64}{test1}, 'b64 sha1 on create'); is($row->sha256_hex, $checks->{'SHA-256'}{hex}{test1}, 'hex sha256 on create'); is($row->sha256b64, $checks->{'SHA-256'}{base64}{test1},'b64 sha256 on create'); is( length($row->sha256_b64_salted), 57, 'correct salted length'); can_ok($row, qw/check_sha1_hex check_sha1_b64/); ok($row->check_sha1_hex('test1'),'Checking hex digest_check_method'); ok($row->check_sha1_b64('test1'),'Checking b64 digest_check_method'); ok($row->check_sha256_b64_salted('test1'), 'Checking salted digest_check_method'); $row->sha1_hex('test2'); is($row->sha1_hex, $checks->{'SHA-1'}{hex}{test2}, 'Checking accessor'); $row->update({sha1_b64 => 'test2', dummy_col => 'test2'}); is($row->sha1_b64, $checks->{'SHA-1'}{base64}{test2}, 'Checking update'); is($row->dummy_col, 'test2', 'dummy on update'); $row->set_column(sha256_hex => 'test2'); is($row->sha256_hex, $checks->{'SHA-256'}{hex}{test2}, 'Checking set_column'); $row->sha256b64('test2'); is($row->sha256b64, $checks->{'SHA-256'}{base64}{test2}, 'custom accessor'); $row->update; my $copy = $row->copy({sha256_b64 => 'test2'}); is($copy->sha1_hex, $checks->{'SHA-1'}{hex}{test2}, 'hex sha1 on copy'); is($copy->sha1_b64, $checks->{'SHA-1'}{base64}{test2}, 'b64 sha1 on copy'); is($copy->sha256_hex, $checks->{'SHA-256'}{hex}{test2}, 'hex sha256 on copy'); is($copy->sha256b64, $checks->{'SHA-256'}{base64}{test2},'b64 sha256 on copy'); my $new = $schema->resultset('SHA')->new( \%create_values ); is($new->sha1_hex, $checks->{'SHA-1'}{hex}{test1}, 'hex sha1 on new'); is($new->sha1_b64, $checks->{'SHA-1'}{base64}{test1}, 'b64 sha1 on new'); is($new->sha256_hex, $checks->{'SHA-256'}{hex}{test1}, 'hex sha256 on new'); is($new->sha256b64, $checks->{'SHA-256'}{base64}{test1}, 'b64 sha256 on new'); $row->sha1_hex(undef); $row->update; is($row->sha1_hex, undef, 'Check undef is passed through'); DBIx-Class-EncodedColumn-0.00015/t/crypt.t000644 001757 001762 00000002055 12723307561 020364 0ustar00wreiswreis000000 000000 use strict; use warnings; use Test::More; use Test::Exception; use DBIx::Class::EncodedColumn::Crypt; my $gen_salt_meth = sub { my @salt_vals = (qw(. /), '0'..'9', 'a'..'z', 'A'..'Z'); return $salt_vals[int(rand(64))] . $salt_vals[int(rand(64))]; }; my ( $col_name, $col_info ) = ( 'password', { salt => $gen_salt_meth } ); my $passwd = 'mypasswd'; my $cripted_pass = crypt($passwd, $gen_salt_meth->()); throws_ok { DBIx::Class::EncodedColumn::Crypt->make_encode_sub( $col_name, { salt => $gen_salt_meth->() } ) } qr{valid.*coderef}i; my $encoder = DBIx::Class::EncodedColumn::Crypt->make_encode_sub( $col_name, $col_info ); my $checker = DBIx::Class::EncodedColumn::Crypt->make_check_sub( $col_name, $col_info ); package MyEncodedColumn; sub new { return bless {}, shift } sub get_column { return $cripted_pass } sub _column_encoders { return { $col_name => $encoder } } package main; isnt($passwd, $encoder->($passwd)); is($cripted_pass, $encoder->($passwd, $cripted_pass)); ok($checker->(MyEncodedColumn->new, $passwd)); done_testing(); DBIx-Class-EncodedColumn-0.00015/t/whirlpool.t000644 001757 001762 00000003603 12723307561 021242 0ustar00wreiswreis000000 000000 use strict; use warnings; use Test::More; use Dir::Self; use File::Spec; use File::Temp 'tempdir'; use lib File::Spec->catdir(__DIR__, 'lib'); use DigestTest::Schema; BEGIN { if( eval 'require Digest; 1' && eval 'require Digest::Whirlpool; 1' ){ plan tests => 7; } else { plan skip_all => 'Digest::Whirlpool not available'; exit; } } #1 DigestTest::Schema->load_classes('Whirlpool'); my $tmp = tempdir( CLEANUP => 1 ); my $db_file = File::Spec->catfile($tmp, 'testdb.sqlite'); my $schema = DigestTest::Schema->connect("dbi:SQLite:dbname=${db_file}"); $schema->deploy({}, File::Spec->catdir(__DIR__, 'var')); my $checks = {}; for my $algorithm( qw/Whirlpool/){ my $maker = Digest->new($algorithm); my $encodings = $checks->{$algorithm} = {}; for my $encoding (qw/base64 hex/){ my $values = $encodings->{$encoding} = {}; my $encoding_method = $encoding eq 'binary' ? 'digest' : ($encoding eq 'hex' ? 'hexdigest' : 'b64digest'); for my $value (qw/test1 test2/){ $maker->reset()->add($value); $values->{$value} = $maker->$encoding_method; } } } my %create_values = (whirlpool_hex => 'test1', whirlpool_b64 => 'test1'); my $row = $schema->resultset('Whirlpool')->create( \%create_values ); is( $row->whirlpool_hex, $checks->{'Whirlpool'}{hex}{test1}, 'Whirlpool hex'); is( $row->whirlpool_b64, $checks->{'Whirlpool'}{base64}{test1}, 'Whirlpool b64'); can_ok( $row, qw/check_whirlpool_hex check_whirlpool_b64/ ); ok( $row->check_whirlpool_hex('test1'), 'Checking hex digest_check_method for Whirlpool'); ok( $row->check_whirlpool_b64('test1'), 'Checking b64 digest_check_method for Whirlpool'); $row->whirlpool_hex('test2'); is( $row->whirlpool_hex, $checks->{'Whirlpool'}{hex}{test2}, 'Checking accessor (Whirlpool)'); $row->update({ whirlpool_b64 => 'test2' }); is( $row->whirlpool_b64, $checks->{'Whirlpool'}{base64}{test2}, 'Checking Update (Whirlpool)'); DBIx-Class-EncodedColumn-0.00015/t/var/000755 001757 001762 00000000000 12723565154 017630 5ustar00wreiswreis000000 000000 DBIx-Class-EncodedColumn-0.00015/t/class_level_encoders.t000644 001757 001762 00000002246 12723307561 023403 0ustar00wreiswreis000000 000000 use strict; use warnings; use Test::More; BEGIN { if( eval 'require Digest' && eval 'require Digest::SHA' ){ plan tests => 1; } else { plan skip_all => 'Digest::SHA not available'; exit; } } { package TestCorrectlySetClassData; use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/EncodedColumn Core/); __PACKAGE__->table('test_register_column'); } TestCorrectlySetClassData->add_columns( sha1_hex => { data_type => 'char', is_nullable => 1, size => 40, encode_column => 1, encode_class => 'Digest', encode_args => { format => 'hex', algorithm => 'SHA-1', }, encode_check_method => 'check_sha1_hex', }, ); my $encoders_1 = TestCorrectlySetClassData->_column_encoders; TestCorrectlySetClassData->add_columns( sha1_b64 => { data_type => 'char', is_nullable => 1, size => 27, encode_column => 1, encode_class => 'Digest', encode_args => { algorithm => 'SHA-1', }, encode_check_method => 'check_sha1_b64', }, ); my $encoders_2 = TestCorrectlySetClassData->_column_encoders; isnt($encoders_1, $encoders_2, 'register_column uses fresh ref for econders'); DBIx-Class-EncodedColumn-0.00015/t/open_pgp.t000644 001757 001762 00000003605 12723307561 021034 0ustar00wreiswreis000000 000000 use strict; use warnings; use Test::More; use Dir::Self; use File::Spec; use File::Temp 'tempdir'; use lib File::Spec->catdir(__DIR__, 'lib'); use DigestTest::Schema; BEGIN { my $math_pari = $ENV{'NO_MATH_PARI'} ? 1 : eval 'require Math::Pari'; if( eval 'require Crypt::OpenPGP' && $math_pari ){ plan tests => 8; } else { plan skip_all => 'Crypt::OpenPGP not available'; exit; } } #1 DigestTest::Schema->load_classes('PGP'); my $tmp = tempdir( CLEANUP => 1 ); my $db_file = File::Spec->catfile($tmp, 'testdb.sqlite'); my $schema = DigestTest::Schema->connect("dbi:SQLite:dbname=${db_file}"); $schema->deploy({}, File::Spec->catdir(__DIR__, 'var')); my $row = $schema->resultset('PGP')->create( { dummy_col => 'Dummy Column', pgp_col_passphrase => 'Test Encrypted Column with Passphrase', pgp_col_key => 'Test Encrypted Column with Key Exchange', pgp_col_key_ps => 'Test Encrypted Column with Key Exchange + Pass', pgp_col_rijndael256 => 'Test Encrypted Column with Rijndael256 Cipher', } ); like($row->pgp_col_passphrase, qr/BEGIN PGP MESSAGE/, 'Passphrase encrypted'); like($row->pgp_col_key, qr/BEGIN PGP MESSAGE/, 'Key encrypted'); like($row->pgp_col_key_ps, qr/BEGIN PGP MESSAGE/, 'Key+Passphrase encrypted'); like($row->pgp_col_rijndael256, qr/BEGIN PGP MESSAGE/, 'Rijndael encrypted'); is( $row->decrypt_pgp_passphrase('Secret Words'), 'Test Encrypted Column with Passphrase', 'Passphrase decryption/encryption' ); is( $row->decrypt_pgp_key, 'Test Encrypted Column with Key Exchange', 'Key Exchange decryption/encryption' ); is( $row->decrypt_pgp_key_ps('Secret Words'), 'Test Encrypted Column with Key Exchange + Pass', 'Secured Key Exchange decryption/encryption' ); is( $row->decrypt_pgp_rijndael256('Secret Words'), 'Test Encrypted Column with Rijndael256 Cipher', 'Passphrase decryption/encryption with Rijndael256 Cipher' ); DBIx-Class-EncodedColumn-0.00015/t/bcrypt.t000644 001757 001762 00000002700 12723307561 020523 0ustar00wreiswreis000000 000000 use strict; use warnings; use Test::More; use utf8; use Dir::Self; use File::Spec; use File::Temp 'tempdir'; use lib File::Spec->catdir(__DIR__, 'lib'); BEGIN { if( eval 'require Crypt::Eksblowfish::Bcrypt' ){ plan tests => 12; use_ok('DigestTest::Schema'); } else { plan skip_all => 'Crypt::Eksblowfish::Bcrypt not available'; exit; } } #1 DigestTest::Schema->load_classes('Bcrypt'); my $tmp = tempdir( CLEANUP => 1 ); my $db_file = File::Spec->catfile($tmp, 'testdb.sqlite'); my $schema = DigestTest::Schema->connect("dbi:SQLite:dbname=${db_file}"); $schema->deploy({}, File::Spec->catdir(__DIR__, 'var')); my %create_values = (bcrypt_1 => 'test1', bcrypt_2 => 'test1'); my $row = $schema->resultset('Bcrypt')->create( \%create_values ); is( length($row->bcrypt_1), 60, 'correct length'); is( length($row->bcrypt_2), 59, 'correct length'); ok( $row->bcrypt_1_check('test1')); ok( $row->bcrypt_2_check('test1')); $row->bcrypt_1('test2'); $row->bcrypt_2('test2'); ok( $row->bcrypt_1_check('test2')); ok( $row->bcrypt_2_check('test2')); $row->bcrypt_1('官话'); $row->update; ok($row->bcrypt_1_check('官话')); # setting to undef avoids call to make_encode_sub $row->bcrypt_1(undef); $row->bcrypt_2(undef); is( $row->bcrypt_1, undef, 'is undef' ); is( $row->bcrypt_2, undef, 'is undef' ); ok( !$row->bcrypt_1_check(undef), "encode_check_method fails for undef"); ok( !$row->bcrypt_2_check(undef), "encode_check_method fails for undef"); DBIx-Class-EncodedColumn-0.00015/t/lib/000755 001757 001762 00000000000 12723565154 017606 5ustar00wreiswreis000000 000000 DBIx-Class-EncodedColumn-0.00015/t/lib/DigestTest/000755 001757 001762 00000000000 12723565154 021665 5ustar00wreiswreis000000 000000 DBIx-Class-EncodedColumn-0.00015/t/lib/DigestTest/Schema.pm000644 001757 001762 00000000131 12723307561 023412 0ustar00wreiswreis000000 000000 package # hide from PAUSE DigestTest::Schema; use base qw/DBIx::Class::Schema/; 1; DBIx-Class-EncodedColumn-0.00015/t/lib/DigestTest/Schema/000755 001757 001762 00000000000 12723565154 023065 5ustar00wreiswreis000000 000000 DBIx-Class-EncodedColumn-0.00015/t/lib/DigestTest/Schema/PGP.pm000644 001757 001762 00000003557 12723307561 024057 0ustar00wreiswreis000000 000000 package # hide from PAUSE DigestTest::Schema::PGP; use strict; use warnings; use base qw/DBIx::Class/; use Dir::Self; use File::Spec; my $pgp_conf = { SecRing => File::Spec->catdir(__DIR__,'secring.gpg'), PubRing => File::Spec->catdir(__DIR__,'pubring.gpg'), }; __PACKAGE__->load_components(qw/EncodedColumn Core/); __PACKAGE__->table('test_pgp'); __PACKAGE__->add_columns( id => { data_type => 'int', is_nullable => 0, is_auto_increment => 1 }, dummy_col => { data_type => 'char', size => 43, encode_column => 0, encode_class => 'Digest', encode_check_method => 'check_dummy_col', }, pgp_col_passphrase => { data_type => 'text', is_nullable => 1, encode_column => 1, encode_class => 'Crypt::OpenPGP', encode_args => { passphrase => 'Secret Words', armour => 1 }, encode_check_method => 'decrypt_pgp_passphrase', }, pgp_col_key => { data_type => 'text', is_nullable => 1, encode_column => 1, encode_class => 'Crypt::OpenPGP', encode_args => { recipient => '1B8924AA', pgp_args => $pgp_conf, armour => 1 }, encode_check_method => 'decrypt_pgp_key', }, pgp_col_key_ps => { data_type => 'text', is_nullable => 1, encode_column => 1, encode_class => 'Crypt::OpenPGP', encode_args => { recipient => '7BEF6294', pgp_args => $pgp_conf, armour => 1 }, encode_check_method => 'decrypt_pgp_key_ps', }, pgp_col_rijndael256 => { data_type => 'text', is_nullable => 1, encode_column => 1, encode_class => 'Crypt::OpenPGP', encode_args => { passphrase => 'Secret Words', armour => 1, pgp_args => $pgp_conf, cipher => 'Rijndael256', }, encode_check_method => 'decrypt_pgp_rijndael256', }, ); __PACKAGE__->set_primary_key('id'); 1; DBIx-Class-EncodedColumn-0.00015/t/lib/DigestTest/Schema/WithTimeStampChild.pm000644 001757 001762 00000001643 12723307561 027126 0ustar00wreiswreis000000 000000 package # hide from PAUSE DigestTest::Schema::WithTimeStampChild; use strict; use warnings; use base qw/DigestTest::Schema::WithTimeStampParent/; __PACKAGE__->table('test_timestamp_order'); __PACKAGE__->add_columns( id => { data_type => 'int', is_nullable => 0, is_auto_increment => 1 }, username => { data_type => 'text', is_nullable => 0 }, password => { data_type => "text", encode_args => { algorithm => "SHA-1", format => "hex", salt_length => 10 }, encode_check_method => "check_password", encode_class => "Digest", encode_column => 1, is_nullable => 0, }, created => { data_type => 'datetime', set_on_create => 1 }, updated => { data_type => 'datetime', set_on_update => 1 } ); __PACKAGE__->set_primary_key('id'); 1; DBIx-Class-EncodedColumn-0.00015/t/lib/DigestTest/Schema/Bcrypt.pm000644 001757 001762 00000001460 12723307561 024663 0ustar00wreiswreis000000 000000 package # hide from PAUSE DigestTest::Schema::Bcrypt; use strict; use warnings; use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/EncodedColumn Core/); __PACKAGE__->table('test_bcrypt'); __PACKAGE__->add_columns( id => { data_type => 'int', is_nullable => 0, is_auto_increment => 1 }, bcrypt_1 => { data_type => 'text', is_nullable => 1, size => 60, encode_column => 1, encode_class => 'Crypt::Eksblowfish::Bcrypt', encode_check_method => 'bcrypt_1_check', }, bcrypt_2 => { data_type => 'text', is_nullable => 1, size => 59, encode_column => 1, encode_class => 'Crypt::Eksblowfish::Bcrypt', encode_args => {key_nul => 0, cost => 6 }, encode_check_method => 'bcrypt_2_check', }, ); __PACKAGE__->set_primary_key('id'); 1; DBIx-Class-EncodedColumn-0.00015/t/lib/DigestTest/Schema/WithTimeStampParent.pm000644 001757 001762 00000000302 12723307561 027323 0ustar00wreiswreis000000 000000 package # hide from PAUSE DigestTest::Schema::WithTimeStampParent; use strict; use warnings; use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/EncodedColumn TimeStamp Core/); 1; DBIx-Class-EncodedColumn-0.00015/t/lib/DigestTest/Schema/WithTimeStampParentWrongOrder.pm000644 001757 001762 00000000314 12723307561 031337 0ustar00wreiswreis000000 000000 package # hide from PAUSE DigestTest::Schema::WithTimeStampParentWrongOrder; use strict; use warnings; use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/TimeStamp EncodedColumn Core/); 1; DBIx-Class-EncodedColumn-0.00015/t/lib/DigestTest/Schema/Whirlpool.pm000644 001757 001762 00000001605 12723307561 025400 0ustar00wreiswreis000000 000000 package # hide from PAUSE DigestTest::Schema::Whirlpool; use strict; use warnings; use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/EncodedColumn Core/); __PACKAGE__->table('test_whirlpool'); __PACKAGE__->add_columns( id => { data_type => 'int', is_nullable => 0, is_auto_increment => 1 }, whirlpool_hex => { data_type => 'char', is_nullable => 1, size => 128, encode_column => 1, encode_class => 'Digest', encode_args => { format => 'hex', algorithm => 'Whirlpool', }, encode_check_method => 'check_whirlpool_hex', }, whirlpool_b64 => { data_type => 'char', is_nullable => 1, size => 86, encode_column => 1, encode_class => 'Digest', encode_args => { algorithm => 'Whirlpool', }, encode_check_method => 'check_whirlpool_b64', }, ); __PACKAGE__->set_primary_key('id'); 1; DBIx-Class-EncodedColumn-0.00015/t/lib/DigestTest/Schema/pubring.gpg000644 001757 001762 00000003475 12723307561 025237 0ustar00wreiswreis000000 000000 H&H\OSʇڛѯညHg eO܆7-fj 2Vh%.ʏxǽsyUɵI R'mwe. 2rHp{|*ߓ|Q:Z:Ia24r\B/"LJ,sc%wևC[DIѪ~c̬@G`pjFowK9Z\ͽ-FU=ڀTוI'@ysa |\b"x7[&wG"5!|3fp>_&H*&!iUFF}M!-aaSE6^}eLBM}K'!Test Keys ` H&#  {bպ{rۼ`o(&d+m:aO_  H)Y^XAcw_KsN&1eMK;R,`'E~ / un8VhNC%glkȮhٞ"lU5fs×w,c"]VQ2kbPD` ThڔϬ9 cN]% c6R =2 J`u;B.$5g!=F&0j.ԽK4 Ð6{1 3I H) {b5pܶꌁo SJf ޣwPyL]j*hdHalN|РPP* w-|>9԰^>2pR慆' 9gD;1(OFMᎽ t0^O raɏ_?ޯvi|_&]]x'!]$w䇏0oYWh/aӷڥ>GJ;!b˔KXNL|Y7 sbTKf"$aW$PpIfP=;_{k9Q=x>#o MYoRf6 vlg`<эxiZtEߪ_q!,1lZ]BfOYMc NНyGs+5JI8}񥭶K$L=줠IKB J}=!BzvDTest Keys (This is a test key. DO NOT USE.) ` H  &$K(z~Rh!]L#PV}o%O H\6sDh`v䤣CUlxEHO-zRHv[2&-Tepԍ^@cϐ5wrc:s6ﴜ?ʒT p#8*54M`O(%Xرk%c&R58zxA/C FXa/Vc~F8eI˲1s a_h8B_7dtHKWx8II[(c]xlGk}iI H &$ ވ-RE"*m̶dS3j%2u?iWDBIx-Class-EncodedColumn-0.00015/t/lib/DigestTest/Schema/secring.gpg000644 001757 001762 00000004004 12723307561 025210 0ustar00wreiswreis000000 000000 H&H\OSʇڛѯညHg eO܆7-fj 2Vh%.ʏxǽsyUɵI R'mwe. 2rHp{|*ߓ|Q:Z:Ia24r\B/"LJ,sc%wևC[DIѪ~c̬@G`pjFowK9Z\ͽ-FU=ڀTוI'@ysa |\b"x7[&wG"5!|3fp>_&H*&!iUFF}M!-aaSE6^}eLBM}K''3|`2 uB˹Tt>8RfvkPZ |̲D4X(d/"w!Test Keys ` H&#  {bպ{rۼ`o(&d+m:aO_ XH)Y^XAcw_KsN&1eMK;R,`'E~ / un8VhNC%glkȮhٞ"lU5fs×w,c"]VQ2kbPD` ThڔϬ9 cN]% c6R =2 J`u;B.$5g!=F&0j.ԽK4 Ð6{1 3'3|`C"͛h8`pOǥ#j X^̈5M"mdsBd&I H) {b5X B"'F-D&!ޑ\}pbߏHalN|РPP* w-|>9԰^>2pR慆' 9gD;1(OFMᎽ t0^O raɏ_?ޯvi|_&]]x'!]$w䇏0oYWh/aӷڥ>GJ;!b˔KXNL|Y7 sbTKf"$aW$PpIfP=;_{k9Q=x>#o MYoRf6 vlg`<эxiZtEߪ_q!,1lZ]BfOYMc NНyGs+5JI8}񥭶K$L=줠IKB J}=!BzvwFZbB>/ DTest Keys (This is a test key. DO NOT USE.) ` H  &$K(z~Rh!]L#PV}o%O1H\6sDh`v䤣CUlxEHO-zRHv[2&-Tepԍ^@cϐ5wrc:s6ﴜ?ʒT p#8*54M`O(%Xرk%c&R58zxA/C FXa/Vc~F8eI˲1s a_h8B_7dtHKWx8II[(c]xlGk}i2d3MlpH"" 7jPɫ$I H &$A'f%U,]c2SF5 }QHoJZDBIx-Class-EncodedColumn-0.00015/t/lib/DigestTest/Schema/WithTimeStampChildWrongOrder.pm000644 001757 001762 00000001723 12723307561 031136 0ustar00wreiswreis000000 000000 package # hide from PAUSE DigestTest::Schema::WithTimeStampChildWrongOrder; use strict; use warnings; use base qw/DigestTest::Schema::WithTimeStampParentWrongOrder/; __PACKAGE__->table('test_timestamp_order'); __PACKAGE__->add_columns( id => { data_type => 'int', is_nullable => 0, is_auto_increment => 1 }, username => { data_type => 'text', is_nullable => 0 }, password => { data_type => "text", encode_args => { algorithm => "SHA-1", format => "hex", salt_length => 10 }, encode_check_method => "check_password", encode_class => "Digest", encode_column => 1, is_nullable => 0, }, created => { data_type => 'datetime', set_on_create => 1 }, updated => { data_type => 'datetime', set_on_create => 1, set_on_update => 1 } ); __PACKAGE__->set_primary_key('id'); 1; DBIx-Class-EncodedColumn-0.00015/t/lib/DigestTest/Schema/WithTimeStamp.pm000644 001757 001762 00000001512 12723307561 026155 0ustar00wreiswreis000000 000000 package # hide from PAUSE DigestTest::Schema::WithTimeStamp; use strict; use warnings; use base qw/DBIx::Class::Core/; __PACKAGE__->load_components(qw/TimeStamp EncodedColumn/); __PACKAGE__->table('test_with_timestamp'); __PACKAGE__->add_columns( id => { data_type => 'int', is_nullable => 0, is_auto_increment => 1 }, bcrypt_1 => { data_type => 'text', is_nullable => 1, size => 60, encode_column => 1, encode_class => 'Crypt::Eksblowfish::Bcrypt', encode_check_method => 'bcrypt_1_check', }, bcrypt_2 => { data_type => 'text', is_nullable => 1, size => 59, encode_column => 1, encode_class => 'Crypt::Eksblowfish::Bcrypt', encode_args => {key_nul => 0, cost => 6 }, encode_check_method => 'bcrypt_2_check', }, ); __PACKAGE__->set_primary_key('id'); 1; DBIx-Class-EncodedColumn-0.00015/t/lib/DigestTest/Schema/SHA.pm000644 001757 001762 00000003160 12723307561 024032 0ustar00wreiswreis000000 000000 package # hide from PAUSE DigestTest::Schema::SHA; use strict; use warnings; use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/EncodedColumn Core/); __PACKAGE__->table('test_sha'); __PACKAGE__->add_columns( id => { data_type => 'int', is_nullable => 0, is_auto_increment => 1 }, dummy_col => { data_type => 'char', size => 43, encode_column => 0, encode_class => 'Digest', encode_check_method => 'check_dummy_col', }, sha1_hex => { data_type => 'char', is_nullable => 1, size => 40, encode_column => 1, encode_class => 'Digest', encode_args => { format => 'hex', algorithm => 'SHA-1', }, encode_check_method => 'check_sha1_hex', }, sha1_b64 => { data_type => 'char', is_nullable => 1, size => 27, encode_column => 1, encode_class => 'Digest', encode_args => { algorithm => 'SHA-1', }, encode_check_method => 'check_sha1_b64', }, sha256_hex => { data_type => 'char', is_nullable => 1, size => 64, encode_column => 1, encode_class => 'Digest', encode_args => { format => 'hex',}, }, sha256_b64 => { data_type => 'char', is_nullable => 1, size => 43, accessor => 'sha256b64', encode_column => 1, encode_class => 'Digest', }, sha256_b64_salted => { data_type => 'char', is_nullable => 1, size => 57, encode_column => 1, encode_class => 'Digest', encode_check_method => 'check_sha256_b64_salted', encode_args => {salt_length => 14} }, ); __PACKAGE__->set_primary_key('id'); 1; DBIx-Class-EncodedColumn-0.00015/t/var/DigestTest-Schema-1.x-SQLite.sql000644 001757 001762 00000002043 12723307561 025364 0ustar00wreiswreis000000 000000 -- -- Created by SQL::Translator::Producer::SQLite -- Created on Mon May 17 13:22:05 2010 -- BEGIN TRANSACTION; -- -- Table: test_bcrypt -- CREATE TABLE test_bcrypt ( id INTEGER PRIMARY KEY NOT NULL, bcrypt_1 text, bcrypt_2 text ); -- -- Table: test_pgp -- CREATE TABLE test_pgp ( id INTEGER PRIMARY KEY NOT NULL, dummy_col char(43) NOT NULL, pgp_col_passphrase text, pgp_col_key text, pgp_col_key_ps text, pgp_col_rijndael256 text ); -- -- Table: test_sha -- CREATE TABLE test_sha ( id INTEGER PRIMARY KEY NOT NULL, dummy_col char(43) NOT NULL, sha1_hex char(40), sha1_b64 char(27), sha256_hex char(64), sha256_b64 char(43), sha256_b64_salted char(57) ); -- -- Table: test_whirlpool -- CREATE TABLE test_whirlpool ( id INTEGER PRIMARY KEY NOT NULL, whirlpool_hex char(128), whirlpool_b64 char(86) ); -- -- Table: test_timestamp_order -- CREATE TABLE test_timestamp_order ( id INTEGER PRIMARY KEY NOT NULL, username TEXT NOT NULL, password TEXT NOT NULL, created TEXT, updated TEXT ); COMMIT; DBIx-Class-EncodedColumn-0.00015/inc/Module/000755 001757 001762 00000000000 12723565154 020573 5ustar00wreiswreis000000 000000 DBIx-Class-EncodedColumn-0.00015/inc/Module/AutoInstall.pm000644 001757 001762 00000062311 12723565147 023375 0ustar00wreiswreis000000 000000 #line 1 package Module::AutoInstall; use strict; use Cwd (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.16'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps, $UpgradeDeps ); my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps, $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps, $PostambleActionsListAllDeps, $PostambleUsed, $NoTest); # 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 _installdeps_target { $InstallDepsTarget = 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 =~ /^--upgradedeps=(.*)$/ ) { $UpgradeDeps = 1; __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::getcwd(); $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 || $InstallDepsTarget; 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 compatibility 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 = _version_of($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 $InstallDepsTarget 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; my $make = $Config::Config{make}; if ($InstallDepsTarget) { print "*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n"; } else { print "*** Dependencies will be installed the next time you type '$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 @_; if ($ENV{PERL5_CPANM_IS_RUNNING}) { return _running_under('cpanminus'); } 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, @modules_to_upgrade ); while (my ($pkg, $ver) = splice(@_, 0, 2)) { # grep out those already installed if (_version_cmp(_version_of($pkg), $ver) >= 0) { push @installed, $pkg; if ($UpgradeDeps) { push @modules_to_upgrade, $pkg, $ver; } } else { push @modules, $pkg, $ver; } } if ($UpgradeDeps) { push @modules, @modules_to_upgrade; @installed = (); @modules_to_upgrade = (); } 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( _version_of($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"; } push @config, 'prereqs', $value; } elsif ( $key eq 'force' ) { push @config, $key, $value; } elsif ( $key eq 'notest' ) { push @config, 'skiptest', $value; } 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|notest)$/; # pseudo-option $CPAN::Config->{$opt} = $opt eq 'urllist' ? [$arg] : $arg; } if ($args{notest} && (not CPAN::Shell->can('notest'))) { die "Your version of CPAN is too old to support the 'notest' pragma"; } 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 = do { if ($args{force}) { CPAN::Shell->force( install => $pkg ) } elsif ($args{notest}) { CPAN::Shell->notest( install => $pkg ) } else { 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::getcwd() ); 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( _version_of($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; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # report version without loading a module sub _version_of { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; foreach my $dir ( @INC ) { next if ref $dir; my $path = File::Spec->catfile($dir, $file); next unless -e $path; require ExtUtils::MM_Unix; return ExtUtils::MM_Unix->parse_version($path); } return undef; } # 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)" ); my $deps_list = join( ',', @Missing, @Existing ); $PostambleActionsUpgradeDeps = "\$(PERL) $0 --config=$config --upgradedeps=$deps_list"; my $config_notest = join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}), 'notest', 1 ) if $Config; $PostambleActionsNoTest = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); $PostambleActionsUpgradeDepsNoTest = "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list"; $PostambleActionsListDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing); my @all = (@Missing, @Existing); $PostambleActionsListAllDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all); 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; my $fragment; $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget; config :: installdeps \t\$(NOECHO) \$(NOOP) AUTO_INSTALL $fragment .= <<"END_MAKE"; checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions installdeps_notest :: \t$PostambleActionsNoTest upgradedeps :: \t$PostambleActionsUpgradeDeps upgradedeps_notest :: \t$PostambleActionsUpgradeDepsNoTest listdeps :: \t$PostambleActionsListDeps listalldeps :: \t$PostambleActionsListAllDeps END_MAKE return $fragment; } 1; __END__ #line 1197 DBIx-Class-EncodedColumn-0.00015/inc/Module/Install.pm000644 001757 001762 00000030217 12723565146 022543 0ustar00wreiswreis000000 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.006; 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.16'; # 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::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); 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::getcwd()) 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 /\n/, $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]): $!"; binmode FH; 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]): $!"; binmode FH; 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]): $!"; binmode FH; 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]): $!"; binmode FH; 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($_[1]) <=> _version($_[2]); } # 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 - 2012 Adam Kennedy. DBIx-Class-EncodedColumn-0.00015/inc/Module/Install/000755 001757 001762 00000000000 12723565154 022201 5ustar00wreiswreis000000 000000 DBIx-Class-EncodedColumn-0.00015/inc/Module/Install/AuthorTests.pm000644 001757 001762 00000002215 12723565147 025026 0ustar00wreiswreis000000 000000 #line 1 package Module::Install::AuthorTests; use 5.005; use strict; use Module::Install::Base; use Carp (); #line 16 use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.002'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } #line 42 sub author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 0); } #line 56 sub recursive_author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 1); } sub _wanted { my $href = shift; sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 } } sub _add_author_tests { my ($self, $dirs, $recurse) = @_; return unless $Module::Install::AUTHOR; my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t'; # XXX: pick a default, later -- rjbs, 2008-02-24 my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests"; @dirs = grep { -d } @dirs; if ($recurse) { require File::Find; my %test_dir; File::Find::find(_wanted(\%test_dir), @dirs); $self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir ); } else { $self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs ); } } #line 107 1; DBIx-Class-EncodedColumn-0.00015/inc/Module/Install/ReadmeFromPod.pm000644 001757 001762 00000010164 12723565146 025226 0ustar00wreiswreis000000 000000 #line 1 package Module::Install::ReadmeFromPod; use 5.006; use strict; use warnings; use base qw(Module::Install::Base); use vars qw($VERSION); $VERSION = '0.26'; { # these aren't defined until after _require_admin is run, so # define them so prototypes are available during compilation. sub io; sub capture(&;@); #line 28 my $done = 0; sub _require_admin { # do this once to avoid redefinition warnings from IO::All return if $done; require IO::All; IO::All->import( '-binary' ); require Capture::Tiny; Capture::Tiny->import ( 'capture' ); return; } } sub readme_from { my $self = shift; return unless $self->is_admin; _require_admin; # Input file my $in_file = shift || $self->_all_from or die "Can't determine file to make readme_from"; # Get optional arguments my ($clean, $format, $out_file, $options); my $args = shift; if ( ref $args ) { # Arguments are in a hashref if ( ref($args) ne 'HASH' ) { die "Expected a hashref but got a ".ref($args)."\n"; } else { $clean = $args->{'clean'}; $format = $args->{'format'}; $out_file = $args->{'output_file'}; $options = $args->{'options'}; } } else { # Arguments are in a list $clean = $args; $format = shift; $out_file = shift; $options = \@_; } # Default values; $clean ||= 0; $format ||= 'txt'; # Generate README print "readme_from $in_file to $format\n"; if ($format =~ m/te?xt/) { $out_file = $self->_readme_txt($in_file, $out_file, $options); } elsif ($format =~ m/html?/) { $out_file = $self->_readme_htm($in_file, $out_file, $options); } elsif ($format eq 'man') { $out_file = $self->_readme_man($in_file, $out_file, $options); } elsif ($format eq 'md') { $out_file = $self->_readme_md($in_file, $out_file, $options); } elsif ($format eq 'pdf') { $out_file = $self->_readme_pdf($in_file, $out_file, $options); } if ($clean) { $self->clean_files($out_file); } return 1; } sub _readme_txt { my ($self, $in_file, $out_file, $options) = @_; $out_file ||= 'README'; require Pod::Text; my $parser = Pod::Text->new( @$options ); my $io = io->file($out_file)->open(">"); my $out_fh = $io->io_handle; $parser->output_fh( *$out_fh ); $parser->parse_file( $in_file ); return $out_file; } sub _readme_htm { my ($self, $in_file, $out_file, $options) = @_; $out_file ||= 'README.htm'; require Pod::Html; my ($o) = capture { Pod::Html::pod2html( "--infile=$in_file", "--outfile=-", @$options, ); }; io->file($out_file)->print($o); # Remove temporary files if needed for my $file ('pod2htmd.tmp', 'pod2htmi.tmp') { if (-e $file) { unlink $file or warn "Warning: Could not remove file '$file'.\n$!\n"; } } return $out_file; } sub _readme_man { my ($self, $in_file, $out_file, $options) = @_; $out_file ||= 'README.1'; require Pod::Man; my $parser = Pod::Man->new( @$options ); my $io = io->file($out_file)->open(">"); my $out_fh = $io->io_handle; $parser->output_fh( *$out_fh ); $parser->parse_file( $in_file ); return $out_file; } sub _readme_pdf { my ($self, $in_file, $out_file, $options) = @_; $out_file ||= 'README.pdf'; eval { require App::pod2pdf; } or die "Could not generate $out_file because pod2pdf could not be found\n"; my $parser = App::pod2pdf->new( @$options ); $parser->parse_from_file($in_file); my ($o) = capture { $parser->output }; io->file($out_file)->print($o); return $out_file; } sub _readme_md { my ($self, $in_file, $out_file, $options) = @_; $out_file ||= 'README.md'; require Pod::Markdown; my $parser = Pod::Markdown->new( @$options ); my $io = io->file($out_file)->open(">"); my $out_fh = $io->io_handle; $parser->output_fh( *$out_fh ); $parser->parse_file( $in_file ); return $out_file; } sub _all_from { my $self = shift; return unless $self->admin->{extensions}; my ($metadata) = grep { ref($_) eq 'Module::Install::Metadata'; } @{$self->admin->{extensions}}; return unless $metadata; return $metadata->{values}{all_from} || ''; } 'Readme!'; __END__ #line 316 DBIx-Class-EncodedColumn-0.00015/inc/Module/Install/Makefile.pm000644 001757 001762 00000027437 12723565146 024272 0ustar00wreiswreis000000 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.16'; @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-separated 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 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } 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.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # 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 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 544 DBIx-Class-EncodedColumn-0.00015/inc/Module/Install/Include.pm000644 001757 001762 00000001015 12723565147 024121 0ustar00wreiswreis000000 000000 #line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @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; DBIx-Class-EncodedColumn-0.00015/inc/Module/Install/AuthorRequires.pm000644 001757 001762 00000001131 12723565147 025517 0ustar00wreiswreis000000 000000 #line 1 use strict; use warnings; package Module::Install::AuthorRequires; use base 'Module::Install::Base'; # cargo cult BEGIN { our $VERSION = '0.02'; our $ISCORE = 1; } sub author_requires { my $self = shift; return $self->{values}->{author_requires} unless @_; my @added; while (@_) { my $mod = shift or last; my $version = shift || 0; push @added, [$mod => $version]; } push @{ $self->{values}->{author_requires} }, @added; $self->admin->author_requires(@added); return map { @$_ } @added; } 1; __END__ #line 92 DBIx-Class-EncodedColumn-0.00015/inc/Module/Install/Win32.pm000644 001757 001762 00000003403 12723565147 023443 0ustar00wreiswreis000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @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; DBIx-Class-EncodedColumn-0.00015/inc/Module/Install/AutoInstall.pm000644 001757 001762 00000004162 12723565147 025003 0ustar00wreiswreis000000 000000 #line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @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 installdeps_target { my ($self, @args) = @_; $self->include('Module::AutoInstall'); require Module::AutoInstall; Module::AutoInstall::_installdeps_target(1); $self->auto_install(@args); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; DBIx-Class-EncodedColumn-0.00015/inc/Module/Install/Metadata.pm000644 001757 001762 00000043302 12723565146 024262 0ustar00wreiswreis000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @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; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } 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 really 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 2\.0' => 'artistic_2', 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<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://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+(v?[\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 hashes 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; DBIx-Class-EncodedColumn-0.00015/inc/Module/Install/Can.pm000644 001757 001762 00000006157 12723565147 023253 0ustar00wreiswreis000000 000000 #line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @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 ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # 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 236 DBIx-Class-EncodedColumn-0.00015/inc/Module/Install/WriteAll.pm000644 001757 001762 00000002376 12723565147 024274 0ustar00wreiswreis000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @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; DBIx-Class-EncodedColumn-0.00015/inc/Module/Install/Base.pm000644 001757 001762 00000002147 12723565146 023416 0ustar00wreiswreis000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.16'; } # 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 DBIx-Class-EncodedColumn-0.00015/inc/Module/Install/Fetch.pm000644 001757 001762 00000004627 12723565147 023603 0ustar00wreiswreis000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @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; DBIx-Class-EncodedColumn-0.00015/lib/DBIx/000755 001757 001762 00000000000 12723565154 020131 5ustar00wreiswreis000000 000000 DBIx-Class-EncodedColumn-0.00015/lib/DBIx/Class/000755 001757 001762 00000000000 12723565154 021176 5ustar00wreiswreis000000 000000 DBIx-Class-EncodedColumn-0.00015/lib/DBIx/Class/EncodedColumn/000755 001757 001762 00000000000 12723565154 023715 5ustar00wreiswreis000000 000000 DBIx-Class-EncodedColumn-0.00015/lib/DBIx/Class/EncodedColumn.pm000644 001757 001762 00000017607 12723564743 024271 0ustar00wreiswreis000000 000000 package DBIx::Class::EncodedColumn; use strict; use warnings; use base qw/DBIx::Class/; use Sub::Name; __PACKAGE__->mk_classdata( '_column_encoders' ); our $VERSION = '0.00015'; $VERSION = eval $VERSION; sub register_column { my $self = shift; my ($column, $info) = @_; $self->next::method(@_); return unless exists $info->{encode_column} && $info->{encode_column} == 1; $self->throw_exception("'encode_class' is a required argument.") unless exists $info->{encode_class} && defined $info->{encode_class}; my $class = $info->{encode_class}; my $args = exists $info->{encode_args} ? $info->{encode_args} : {}; $self->throw_exception("'encode_args' must be a hashref") unless ref $args eq 'HASH'; $class = join("::", 'DBIx::Class::EncodedColumn', $class); eval "require ${class};"; $self->throw_exception("Failed to use encode_class '${class}': $@") if $@; defined( my $encode_sub = eval{ $class->make_encode_sub($column, $args) }) || $self->throw_exception("Failed to create encoder with class '$class': $@"); $self->_column_encoders({$column => $encode_sub, %{$self->_column_encoders || {}}}); if ( exists $info->{encode_check_method} && $info->{encode_check_method} ){ no strict 'refs'; defined( my $check_sub = eval{ $class->make_check_sub($column, $args) }) || $self->throw_exception("Failed to create checker with class '$class': $@"); my $name = join '::', $self->result_class, $info->{encode_check_method}; *$name = subname $name, $check_sub; } } sub set_column { my $self = shift; return $self->next::method(@_) unless defined $_[1]; my $encs = $self->_column_encoders; if(exists $encs->{$_[0]} && defined(my $encoder = $encs->{$_[0]})){ return $self->next::method($_[0], $encoder->($_[1])); } $self->next::method(@_); } sub new { my($self, $attr, @rest) = @_; my $encoders = $self->_column_encoders; for my $col (grep { defined $encoders->{$_} } keys %$encoders ) { next unless exists $attr->{$col} && defined $attr->{$col}; $attr->{$col} = $encoders->{$col}->( $attr->{$col} ); } return $self->next::method($attr, @rest); } 1; __END__; =head1 NAME DBIx::Class::EncodedColumn - Automatically encode columns =head1 SYNOPSIS In your L Result class (sometimes erroneously referred to as the 'table' class): __PACKAGE__->load_components(qw/EncodedColumn ... Core/); #Digest encoder with hex format and SHA-1 algorithm __PACKAGE__->add_columns( 'password' => { data_type => 'CHAR', size => 40, encode_column => 1, encode_class => 'Digest', encode_args => {algorithm => 'SHA-1', format => 'hex'}, } #SHA-1 / hex encoding / generate check method __PACKAGE__->add_columns( 'password' => { data_type => 'CHAR', size => 40 + 10, encode_column => 1, encode_class => 'Digest', encode_args => {algorithm => 'SHA-1', format => 'hex', salt_length => 10}, encode_check_method => 'check_password', } #MD5 / base64 encoding / generate check method __PACKAGE__->add_columns( 'password' => { data_type => 'CHAR', size => 22, encode_column => 1, encode_class => 'Digest', encode_args => {algorithm => 'MD5', format => 'base64'}, encode_check_method => 'check_password', } #Eksblowfish bcrypt / cost of 8/ no key_nul / generate check method __PACKAGE__->add_columns( 'password' => { data_type => 'CHAR', size => 59, encode_column => 1, encode_class => 'Crypt::Eksblowfish::Bcrypt', encode_args => { key_nul => 0, cost => 8 }, encode_check_method => 'check_password', } In your application code: #updating the value. $row->password('plaintext'); my $digest = $row->password; #checking against an existing value with a check_method $row->check_password('old_password'); #true $row->password('new_password'); $row->check_password('new_password'); #returns true $row->check_password('old_password'); #returns false B The component needs to be loaded I Core and other components such as Timestamp. Core should always be last. E.g: __PACKAGE__->load_components(qw/EncodedColumn TimeStamp Core/); =head1 DESCRIPTION This L component can be used to automatically encode a column's contents whenever the value of that column is set. This module is similar to the existing L, but there is some key differences: =over 4 =item C performs the encode operation on C and C, and C performs the operation when the value is set, or on C. =item C supports only algorithms of the L family. C employs a set of thin wrappers around different cipher modules to provide support for any cipher you wish to use and wrappers are very simple to write (typically less than 30 lines). =item C supports having more than one encoded column per table and each column can use a different cipher. =item C adds only one item to the namespace of the object utilizing it (C<_column_encoders>). =back There is, unfortunately, some features that C doesn't support. C supports changing certain options at runtime, as well as the option to not automatically encode values on set. The author of this module found these options to be non-essential and omitted them by design. =head1 Options added to add_column If any one of these options is present the column will be treated as a digest column and all of the defaults will be applied to the rest of the options. =head2 encode_enable => 1 Enable automatic encoding of column values. If this option is not set to true any other options will become no-ops. =head2 encode_check_method => $method_name By using the encode_check_method attribute when you declare a column you can create a check method for that column. The check method accepts a plain text string, and returns a boolean that indicates whether the digest of the provided value matches the current value. =head2 encode_class The class to use for encoding. Available classes are: =over 4 =item C - uses L and requires L to be installed =item C - uses L requires L to be installed as well as the algorithm required (L, L, etc) =item C - L and requires L to be installed =back Please see the relevant class's documentation for information about the specific arguments accepted by each and make sure you include the encoding algorithm (e.g. L) in your application's requirements. =head1 EXTENDED METHODS The following L method is extended: =over 4 =item B - Handle the options described above. =back The following L methods are extended by this module: =over 4 =item B - Encode the columns on new() so that copy and create DWIM. =item B - Encode values whenever column is set. =back =head1 SEE ALSO L, L, L =head1 AUTHOR Guillermo Roditi (groditi) Inspired by the original module written by Tom Kirkpatrick (tkp) featuring contributions from Guillermo Roditi (groditi) and Marc Mims =head1 CONTRIBUTORS jshirley - J. Shirley kentnl - Kent Fredric mst - Matt S Trout wreis - Wallace reis =head1 COPYRIGHT Copyright (c) the DBIx::Class::EncodedColumn L and L as listed above. =head1 LICENSE This library is free software and may be distributed under the same terms as perl itself. =cut DBIx-Class-EncodedColumn-0.00015/lib/DBIx/Class/EncodedColumn/Crypt.pm000644 001757 001762 00000002032 12723307561 025345 0ustar00wreiswreis000000 000000 package DBIx::Class::EncodedColumn::Crypt; use strict; use warnings; our $VERSION = '0.01'; sub make_encode_sub { my ($class, $col, $args) = @_; my $gen_salt_meth = $args->{'salt'}; die "Valid 'salt' is a coderef which returns the salt string." unless ref $gen_salt_meth eq 'CODE'; return sub { my ($plain_text, $salt) = @_; $salt ||= $gen_salt_meth->(); return crypt($plain_text, $salt); }; } sub make_check_sub { my($class, $col, $args) = @_; #fast fast fast return eval qq^ sub { my \$col_v = \$_[0]->get_column('${col}'); \$_[0]->_column_encoders->{${col}}->(\$_[1], \$col_v) eq \$col_v; } ^ || die($@); } 1; __END__; =head1 NAME DBIx::Class::EncodedColumn::Crypt - Encrypt columns using crypt() =head1 SEE ALSO L =head1 AUTHOR wreis: Wallace reis =head1 LICENSE This library is free software, you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBIx-Class-EncodedColumn-0.00015/lib/DBIx/Class/EncodedColumn/Crypt/000755 001757 001762 00000000000 12723565154 025016 5ustar00wreiswreis000000 000000 DBIx-Class-EncodedColumn-0.00015/lib/DBIx/Class/EncodedColumn/Digest.pm000644 001757 001762 00000013455 12723307561 025476 0ustar00wreiswreis000000 000000 package DBIx::Class::EncodedColumn::Digest; use strict; use warnings; use Digest; our $VERSION = '0.00001'; my %digest_lengths = ( 'MD2' => { base64 => 22, binary => 16, hex => 32 }, 'MD4' => { base64 => 22, binary => 16, hex => 32 }, 'MD5' => { base64 => 22, binary => 16, hex => 32 }, 'SHA-1' => { base64 => 27, binary => 20, hex => 40 }, 'SHA-256' => { base64 => 43, binary => 32, hex => 64 }, 'SHA-384' => { base64 => 64, binary => 48, hex => 96 }, 'SHA-512' => { base64 => 86, binary => 64, hex => 128 }, 'CRC-CCITT' => { base64 => 2, binary => 3, hex => 3 }, 'CRC-16' => { base64 => 6, binary => 5, hex => 4 }, 'CRC-32' => { base64 => 14, binary => 10, hex => 8 }, 'Adler-32' => { base64 => 6, binary => 4, hex => 8 }, 'Whirlpool' => { base64 => 86, binary => 64, hex => 128 }, 'Haval-256' => { base64 => 44, binary => 32, hex => 64 }, ); my @salt_pool = ('A' .. 'Z', 'a' .. 'z', 0 .. 9, '+','/','='); sub make_encode_sub { my($class, $col, $args) = @_; my $for = $args->{format} ||= 'base64'; my $alg = $args->{algorithm} ||= 'SHA-256'; my $slen = $args->{salt_length} ||= 0; die("Valid Digest formats are 'binary', 'hex' or 'base64'. You used '$for'.") unless $for =~ /^(?:hex|base64|binary)$/; defined(my $object = eval{ Digest->new($alg) }) || die("Can't use Digest algorithm ${alg}: $@"); my $format_method = $for eq 'binary' ? 'digest' : ($for eq 'hex' ? 'hexdigest' : 'b64digest'); #thanks Haval for breaking the standard. thanks! $format_method = 'base64digest 'if ($alg eq 'Haval-256' && $for eq 'base64'); my $encoder = sub { my ($plain_text, $salt) = @_; $salt ||= join('', map { $salt_pool[int(rand(65))] } 1 .. $slen); $object->reset()->add($plain_text.$salt); my $digest = $object->$format_method; #print "${plain_text}\t ${salt}:\t${digest}${salt}\n" if $salt; return $digest.$salt; }; #in case i didn't prepopulate it $digest_lengths{$alg}{$for} ||= length($encoder->('test1')); return $encoder; } sub make_check_sub { my($class, $col, $args) = @_; #this is the digest length my $len = $digest_lengths{$args->{algorithm}}{$args->{format}}; die("Unable to find digest length") unless defined $len; #fast fast fast return eval qq^ sub { my \$col_v = \$_[0]->get_column('${col}'); my \$salt = substr(\$col_v, ${len}); \$_[0]->_column_encoders->{${col}}->(\$_[1], \$salt) eq \$col_v; } ^ || die($@); } 1; __END__; =head1 NAME DBIx::Class::EncodedColumn::Digest - Digest backend =head1 SYNOPSYS #SHA-1 / hex encoding / generate check method __PACKAGE__->add_columns( 'password' => { data_type => 'CHAR', size => 40 + 10, encode_column => 1, encode_class => 'Digest', encode_args => {algorithm => 'SHA-1', format => 'hex', salt_length => 10}, encode_check_method => 'check_password', } #SHA-256 / base64 encoding / generate check method __PACKAGE__->add_columns( 'password' => { data_type => 'CHAR', size => 40, encode_column => 1, encode_class => 'Digest', encode_check_method => 'check_password', #no encode_args necessary because these are the defaults ... } =head1 DESCRIPTION =head1 ACCEPTED ARGUMENTS =head2 format The encoding to use for the digest. Valid values are 'binary', 'hex', and 'base64'. Will default to 'base64' if not specified. =head2 algorithm The digest algorithm to use for the digest. You may specify any valid L algorithm. Examples are L, L, L etc. Will default to 'SHA-256' if not specified. See L for supported digest algorithms. =head2 salt_length If you would like to use randomly generated salts to encode values make sure this option is set to > 0. Salts will be automatically generated at encode time and will be appended to the end of the digest. Please make sure that you remember to make sure that to expand the size of your db column to have enough space to store both the digest AND the salt. Please see list below for common digest lengths. =head1 METHODS =head2 make_encode_sub $column_name, \%encode_args Returns a coderef that takes two arguments, a plaintext value and an optional salt and returns the encoded value with the salt appended to the end of the digest. If a salt is not provided and the salt_length option was greater than zero it will be randomly generated. =head2 make_check_sub $column_name, \%encode_args Returns a coderef that takes the row object and a plaintext value and will return a boolean if the plaintext matches the encoded value. This is typically used for password authentication. =head1 COMMON DIGEST LENGTHS CIPHER | Binary | Base64 | Hex --------------------------------------- | MD2 | 16 | 22 | 32 | | MD4 | 16 | 22 | 32 | | MD5 | 16 | 22 | 32 | | SHA-1 | 20 | 27 | 40 | | SHA-256 | 32 | 43 | 64 | | SHA-384 | 48 | 64 | 96 | | SHA-512 | 64 | 86 | 128 | | CRC-CCITT | 3 | 2 | 3 | | CRC-16 | 5 | 6 | 4 | | CRC-32 | 10 | 14 | 8 | | Adler-32 | 4 | 6 | 8 | | Whirlpool | 64 | 86 | 128 | | Haval-256 | 32 | 44 | 64 | --------------------------------------- =head1 SEE ALSO L, L, L =head1 AUTHOR Guillermo Roditi (groditi) Based on the Vienna WoC ToDo manager code by Matt S trout (mst) =head1 CONTRIBUTORS See L =head1 LICENSE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBIx-Class-EncodedColumn-0.00015/lib/DBIx/Class/EncodedColumn/Crypt/OpenPGP.pm000644 001757 001762 00000010252 12723307561 026620 0ustar00wreiswreis000000 000000 package DBIx::Class::EncodedColumn::Crypt::OpenPGP; use strict; use warnings; use Carp; use Crypt::OpenPGP; our $VERSION = '0.01'; =head1 NAME DBIx::Class::EncodedColumn::Crypt::OpenPGP - Encrypt columns using Crypt::OpenPGP =head1 SYNOPSIS __PACKAGE__->add_columns( 'secret_data' => { data_type => 'TEXT', encode_column => 1, encode_class => 'Crypt::OpenPGP', encode_args => { recipient => '7BEF6294', }, encode_check_method => 'decrypt_data', }; my $row = $schema->resultset('EncryptedClass') ->create({ secret_data => 'This is secret' }); is( $row->decrypt_data('Private Key Passphrase'), 'This is secret', 'PGP/GPG Encryption works!' ); =head1 DESCRIPTION This is a conduit to working with L, so that you can encrypt data in your database using gpg. Currently this module only handles encrypting but it may add signing of columns in the future =head1 CONFIGURATION In the column definition, specify the C hash as listed in the synopsis. The C is required if doing key exchange encryption, or if you want to use symmetric key encryption using a passphrase you can specify a C option: encode_args => { passphrase => "Shared Secret" } If you have a separate path to your public and private key ring file, or if you have alternative L configuration, you can specify the constructor args using the C configuration key: encode_args => { pgp_args => { SecRing => "$FindBin::Bin/var/secring.gpg", PubRing => "$FindBin::Bin/var/pubring.gpg", } } The included tests cover good usage, and it is advised to briefly browse through them. Also, remember to keep your private keys secure! =cut my %VALID_ENCODE_ARGS = ( 'compat' => 'Compat', 'cipher' => 'Cipher', 'compress' => 'Compress', 'mdc' => 'MDC', ); sub make_encode_sub { my ( $class, $col, $args ) = @_; my ( $method, $method_arg ); my $armour = defined $args->{armour} ? $args->{armour} : 0; if ( defined $args->{passphrase} ) { $method = 'Passphrase'; $method_arg = $args->{passphrase}; } elsif ( defined $args->{recipient} ) { $method = 'Recipients'; $method_arg = $args->{recipient}; } my @other; for my $opt (keys %VALID_ENCODE_ARGS) { if ( defined $args->{$opt} ) { push @other, $VALID_ENCODE_ARGS{$opt} => $args->{$opt}; } } my $pgp = _get_pgp_obj_from_args($args); my $encoder = sub { my ( $plain_text, $settings ) = @_; my $val = $pgp->encrypt( Data => $plain_text, $method => $method_arg, Armour => $armour, @other, ); croak "Unable to encrypt $col; check $method parameter (is $method_arg) (and that the key is known)" unless $val; return $val; }; return $encoder; } sub make_check_sub { my ( $class, $col, $args ) = @_; my $pgp = _get_pgp_obj_from_args($args); return sub { my ( $self, $passphrase ) = @_; my $text = $self->get_column($col); my @res; if ( defined $passphrase ) { @res = $pgp->decrypt( Passphrase => $passphrase, Data => $text ); } else { @res = $pgp->decrypt( Data => $text ); } croak $pgp->errstr unless $res[0]; # Handle additional stuff in $res[1] and [2]? return $res[0]; }; } sub _get_pgp_obj_from_args { my ( $args ) = @_; my $pgp; if ( $args->{pgp_args} and ref $args->{pgp_args} eq 'HASH' ) { $pgp = Crypt::OpenPGP->new( %{ $args->{pgp_args} } ); } elsif ( $args->{pgp_object} and $args->{pgp_object}->isa('Crypt::OpenPGP') ) { $pgp = $args->{pgp_object}; } else { $pgp = Crypt::OpenPGP->new; } croak "Unable to get initialize a Crypt::OpenPGP object" unless $pgp; return $pgp; } =head1 AUTHOR J. Shirley =head1 LICENSE This library is free software, you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; DBIx-Class-EncodedColumn-0.00015/lib/DBIx/Class/EncodedColumn/Crypt/Eksblowfish/000755 001757 001762 00000000000 12723565154 027276 5ustar00wreiswreis000000 000000 DBIx-Class-EncodedColumn-0.00015/lib/DBIx/Class/EncodedColumn/Crypt/Eksblowfish/Bcrypt.pm000644 001757 001762 00000006363 12723307561 031103 0ustar00wreiswreis000000 000000 package DBIx::Class::EncodedColumn::Crypt::Eksblowfish::Bcrypt; use strict; use warnings; use Crypt::Eksblowfish::Bcrypt (); use Encode qw(is_utf8 encode_utf8); our $VERSION = '0.00001'; sub make_encode_sub { my($class, $col, $args) = @_; my $cost = exists $args->{cost} ? $args->{cost} : 8; my $nul = exists $args->{key_nul} ? $args->{key_nul} : 1; die("Valid 'key_null' values are '1' and '0'. You used '${nul}'.") unless $nul =~ /^[01]$/; die("Valid 'cost' are 1 or 2 digit integers. You used '${cost}'.") unless $cost =~ /^\d\d?$/; $nul = $nul ? 'a' : ''; $cost = sprintf("%02i", 0+$cost); # It must begin with "$2", optional "a", "$", two digits, "$" my $settings_base = join('','$2',$nul,'$',$cost, '$'); my $encoder = sub { my ($plain_text, $settings_str) = @_; if ( is_utf8($plain_text) ) { # Bcrypt expects octets $plain_text = encode_utf8($plain_text); } unless ( $settings_str ) { my $salt = join('', map { chr(int(rand(256))) } 1 .. 16); $salt = Crypt::Eksblowfish::Bcrypt::en_base64( $salt ); $settings_str = $settings_base.$salt; } return Crypt::Eksblowfish::Bcrypt::bcrypt($plain_text, $settings_str); }; return $encoder; } sub make_check_sub { my($class, $col, $args) = @_; #fast fast fast return eval qq^ sub { my \$col_v = \$_[0]->get_column('${col}'); return unless defined \$col_v; \$_[0]->_column_encoders->{${col}}->(\$_[1], \$col_v) eq \$col_v; } ^ || die($@); } 1; __END__; =head1 NAME DBIx::Class::EncodedColumn::Crypt::Eksblowfish::Bcrypt - Eksblowfish bcrypt backend =head1 SYNOPSYS #Eksblowfish bcrypt / cost of 8/ no key_nul / generate check method __PACKAGE__->add_columns( 'password' => { data_type => 'CHAR', size => 59, encode_column => 1, encode_class => 'Crypt::Eksblowfish::Bcrypt', encode_args => { key_nul => 0, cost => 8 }, encode_check_method => 'check_password', } =head1 DESCRIPTION =head1 ACCEPTED ARGUMENTS =head2 key_nul => [01] Defaults to true. From the L docs Boolean: whether to append a NUL to the password before using it as a key. The algorithm as originally devised does not do this, but it was later modified to do it. The version that does append NUL is to be preferred; not doing so is supported only for backward compatibility. =head2 cost => \d\d? A single or double digit non-negative integer representing the cost of the hash function. Defaults to 8. =head1 METHODS =head2 make_encode_sub $column_name, \%encode_args Returns a coderef that accepts a plaintext value and returns an encoded value =head2 make_check_sub $column_name, \%encode_args Returns a coderef that when given the row object and a plaintext value will return a boolean if the plaintext matches the encoded value. This is typically used for password authentication. =head1 SEE ALSO L, L, L =head1 AUTHOR Guillermo Roditi (groditi) Based on the Vienna WoC ToDo manager code by Matt S trout (mst) =head1 LICENSE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut