Crypt-Util-0.11/000755 000765 000024 00000000000 11377441031 015136 5ustar00nothingmuchstaff000000 000000 Crypt-Util-0.11/Changes000644 000765 000024 00000002730 11377440760 016443 0ustar00nothingmuchstaff000000 000000 0.11 - add missing thaw_tamper_proof_string method 0.10 - %Digest::MMAP contains scalars from version 1.16 - switch to Moose 0.09 - Forgot to Moosify Class::Accessor::Fast 0.08 - Use Squirrel instead of Moose for better startup time when Moose is not loaded - Fix unpack/pack usage under 5.8 - Missing dependency fixed (namespace::clean) 0.07 - Digest::CMAC support - Crypt::EAX support - nonce generation using L - Moosified - MIME::Base64::URLSafe support - Skip certain tests when nonrequired modules are not available 0.06 - Tamper resistence is now based on the authenticating crypto modes 0.05 - Ugh, forgot to regen .pmc *again* 0.04 - Missing dep 0.03 - refactor data packing - prepare for EAX/OCB block cipher modes wrt tamper resistent strings 0.02 - Rerelease with non-broken .pmc file =( 0.01 - Documentation improvements - Rename tamper_protect* to tamper_proof 0.01_04 - Rerelease with the TT processed .pmc 0.01_03 - MAC based digests - MAC based tamper protected strings - stub for OCB based tamper protected strings 0.01_02 - Make Digest::MultiHash more predictable, so that varying installs will generate the same hashes. - Use SHA-512 to hash passphrases into variable width keys - Refactor Digest::MoreFallbacks out of Crypt::Util - Introduce a SHA* dependency (Digest::SHA, Digest::SHA2, or Digest::SHA::PurePerl will satisfy it) - Doc improvements 0.01_01 - Initial release Crypt-Util-0.11/inc/000755 000765 000024 00000000000 11377441031 015707 5ustar00nothingmuchstaff000000 000000 Crypt-Util-0.11/lib/000755 000765 000024 00000000000 11377441031 015704 5ustar00nothingmuchstaff000000 000000 Crypt-Util-0.11/Makefile.PL000644 000765 000024 00000003341 11267165721 017120 0ustar00nothingmuchstaff000000 000000 #!/usr/bin/perl -w use strict; use inc::Module::Install 0.91; name 'Crypt-Util'; perl_version '5.008'; requires 'Moose' => '0.92'; requires 'Digest' => 0; requires 'Sub::Exporter' => 0; requires 'Storable' => 0; requires 'Data::GUID' => 0; requires 'namespace::clean' => '0.08'; build_requires 'Test::More' => 0; build_requires 'Test::use::ok' => 0; build_requires 'Test::Exception' => 0; recommends 'MIME::Base64' => 0; recommends 'MIME::Base64::URLSafe' => 0; recommends 'MIME::Base32' => 0; recommends 'URI::Escape' => 0; recommends 'Crypt::CFB' => 0; # stream ciphers recommends 'Crypt::CBC' => 0; # block ciphers recommends 'Crypt::EAX' => '0.04'; # AEAD mode recommends 'Crypt::Rijndael' => 0; # AES recommends 'Crypt::Serpent' => 0; # AES finalist recommends 'Crypt::Twofish' => 0; # AES finalist recommends 'Crypt::RC6' => 0; # AES finalist recommends 'Crypt::Blowfish' => 0; # still widely in use recommends 'Crypt::DES' => 0; # still widely in use # Digest::MultiHash requires SHA-1 # Crypt::Utils requires SHA-512 for key munging unless ( eval { require Digest::SHA } or eval { require Digest::SHA2 } ) { # PurePerl will do (Digest::MoreFallbacks) unless ( eval { require Digest::SHA::PurePerl } ) { requires "Digest::SHA::PurePerl" => 0 } # But for performance Digest::SHA is preferred recommends 'Digest::SHA' => 0; } recommends 'Crypt::RIPEMD160' => 0; # it's hip recommends 'Digest::Whirlpool' => 0; # it's happenning recommends 'Digest::MD5' => 0; # it's still alive =( recommends "Digest::HMAC" => 0; recommends "Digest::CMAC" => 0; license "MIT"; all_from 'lib/Crypt/Util.pm'; sign; WriteAll; Crypt-Util-0.11/MANIFEST000644 000765 000024 00000001051 11377441031 016264 0ustar00nothingmuchstaff000000 000000 Changes inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Crypt/Util.pm lib/Crypt/Util.pmc lib/Digest/MoreFallbacks.pm lib/Digest/MultiHash.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml t/basic.t t/digest.t t/encoding.t t/encrypt.t t/exported.t t/multihash.t t/tamper.t SIGNATURE Public-key signature (added by MakeMaker) Crypt-Util-0.11/MANIFEST.SKIP000644 000765 000024 00000001143 11267165745 017050 0ustar00nothingmuchstaff000000 000000 # Avoid version control files. \bRCS\b \bCVS\b \bSCCS\b ,v$ \B\.svn\b \B\.git\b \b_darcs\b # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ # Avoid Devel::Cover files. \bcover_db\b ### DEFAULT MANIFEST.SKIP ENDS HERE #### \.DS_Store$ \.sw.$ (\w+-)*(\w+)-\d\.\d+(?:\.tar\.gz)?$ \.t\.log$ \.prove$ # XS shit \.(?:bs|c|o)$ \.gitignore$ Crypt-Util-0.11/META.yml000644 000765 000024 00000001732 11377441023 016413 0ustar00nothingmuchstaff000000 000000 --- abstract: 'A lightweight Crypt/Digest convenience API' author: - 'Yuval Kogman, ' build_requires: ExtUtils::MakeMaker: 6.42 Test::Exception: 0 Test::More: 0 Test::use::ok: 0 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 0.95' license: MIT meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Crypt-Util no_index: directory: - inc - t recommends: Crypt::Blowfish: 0 Crypt::CBC: 0 Crypt::CFB: 0 Crypt::DES: 0 Crypt::EAX: 0.04 Crypt::RC6: 0 Crypt::RIPEMD160: 0 Crypt::Rijndael: 0 Crypt::Serpent: 0 Crypt::Twofish: 0 Digest::CMAC: 0 Digest::HMAC: 0 Digest::MD5: 0 Digest::Whirlpool: 0 MIME::Base32: 0 MIME::Base64: 0 MIME::Base64::URLSafe: 0 URI::Escape: 0 requires: Data::GUID: 0 Digest: 0 Moose: 0.92 Storable: 0 Sub::Exporter: 0 namespace::clean: 0.08 perl: 5.8.0 version: 0.11 Crypt-Util-0.11/SIGNATURE000644 000765 000024 00000004362 11377441031 016427 0ustar00nothingmuchstaff000000 000000 This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.62. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 b56c2a234869a6f0ee3a69203f79eef38af4ea57 Changes SHA1 1804d0b8b369134f9f0efdc6085152ede7115042 MANIFEST SHA1 606bd6424682249397d63caf905f651178a4d6cc MANIFEST.SKIP SHA1 ad2ad330a73d838b9dc42fbca4496b225bbb0b90 META.yml SHA1 c0d54514f51b8ee6e7c8cc7096ce38ca34fad095 Makefile.PL SHA1 1ebec4119486a032a5612a403e8d7b7be973e938 inc/Module/Install.pm SHA1 24038af925a69df41972971356ccce885b0fe2ad inc/Module/Install/Base.pm SHA1 8f96eddfef548c9328457fbb17a121631cda356b inc/Module/Install/Can.pm SHA1 ec29048e48edd9c9c55f9de7b773bd7c904335ad inc/Module/Install/Fetch.pm SHA1 0384525d85d51e99532e3ad8729d870113646d14 inc/Module/Install/Makefile.pm SHA1 38c657de4d91f5a60ff8e6c6f6a5547daf7c4ab2 inc/Module/Install/Metadata.pm SHA1 5c25f1104c0038041e3b93e0660c39171e4caf2b inc/Module/Install/Win32.pm SHA1 94d47349c803c4bd2a9230d25e4db0b6aaf1acd8 inc/Module/Install/WriteAll.pm SHA1 6a8f71f442c6569df6b42e7879789fb6e145dec5 lib/Crypt/Util.pm SHA1 c8724efa449717c50974842098aeef31c3065fcb lib/Crypt/Util.pmc SHA1 cd53242b2a24e0a7e3d79d3af5ffafe35363be85 lib/Digest/MoreFallbacks.pm SHA1 1c551fb8a1a321d2ed2ba143588af80cab5399ed lib/Digest/MultiHash.pm SHA1 79ef07c9b7580389a5dc9e5ecf5a0c18aaeeb58b t/basic.t SHA1 b824203d1c809c52f78649e5ed2c14aa9833ce9e t/digest.t SHA1 5caaf82cf60dc2e3dbb49b75d7278f38dfbb4738 t/encoding.t SHA1 cd69b1fe06f9759b94895eb3d28084e9795a7c49 t/encrypt.t SHA1 e2a1eafec70c6a41551106a97208ee06f2496bcd t/exported.t SHA1 9b8429918af821d512626ecac1559d9f108e6a7b t/multihash.t SHA1 22c39d4208ddc84253a87c8ccc57da09cfce7e36 t/tamper.t -----BEGIN PGP SIGNATURE----- Version: GnuPG/MacGPG2 v2.0.12 (Darwin) iEYEARECAAYFAkv+QhkACgkQVCwRwOvSdBiJ9QCfTCPR6t1NfQHJONHJGUxIcw1a ZNMAniGnXRI+IIZjKCLGOOHfy2gyWkEe =I0M7 -----END PGP SIGNATURE----- Crypt-Util-0.11/t/000755 000765 000024 00000000000 11377441031 015401 5ustar00nothingmuchstaff000000 000000 Crypt-Util-0.11/t/basic.t000644 000765 000024 00000003537 11131763600 016654 0ustar00nothingmuchstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More 'no_plan'; use ok "Crypt::Util"; can_ok "Crypt::Util" => qw/ cipher_object digest_object /; my $c = Crypt::Util->new; isa_ok( $c, "Crypt::Util" ); ok( !$c->has_default_cipher, "no default cipher" ); SKIP: { my $fallback_cipher = eval { $c->fallback_cipher }; skip "Couldn't load any cipher", 8 unless $fallback_cipher; skip "Couldn't load any mode", 8 unless eval { $c->fallback_mode }; ok( defined($fallback_cipher), "fallback defined" ); my $cipher = $c->cipher_object( key => "foo" ); can_ok( $cipher, qw/encrypt decrypt/ ); my $ciphertext = $cipher->encrypt("foo"); $cipher->reset if $cipher->can("reset"); is( $cipher->decrypt($ciphertext), "foo", "round trip encryption" ); $c->default_key("moose"); my ( $binary, $encoded ) = map { $c->encrypt_string( string => "The quick brown fox had a crush on the lazy moose. One day she wrote the moose a love letter but since he was lazy he never replied. The end.", encode => $_, ) } 0, 1; like( $encoded, qr{^[\w\+\*\-/=]+$}, "no funny chars", ); cmp_ok( $binary, "ne", $encoded, "encoded != binary" ); cmp_ok( length($binary), "<", length($encoded), "encoded is longer" ); is( $c->decrypt_string( string => $encoded, decode => 1 ), $c->decrypt_string( string => $binary ), "decoded == binary" ); } ok( !$c->has_default_digest, "no default digest" ); my $fallback_digest = eval { $c->fallback_digest }; SKIP: { skip "Couldn't load any digest", 4 if $@ =~ /^Couldn't load any digest/; ok( !$@, "no unexpected error" ); ok( defined($fallback_digest), "fallback defined" ); my $digest = $c->digest_object; can_ok( $digest, qw/add digest/ ); $digest->add("foo"); my $foo_digest = $digest->digest; $digest->add("bar"); my $bar_digest = $digest->digest; cmp_ok( $foo_digest, "ne", $bar_digest, "digests differ" ); } Crypt-Util-0.11/t/digest.t000644 000765 000024 00000004166 11131763600 017051 0ustar00nothingmuchstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Exception; use Crypt::Util; my ( $c, $fallback_digest, $fallback_mac ); BEGIN { $c = Crypt::Util->new; $fallback_digest = eval { $c->fallback_digest }; plan skip_all => "Couldn't load any digest" if $@; $fallback_mac = eval { $c->fallback_mac }; plan skip_all => "Couldn't load any mac" if $@; plan 'no_plan'; } my $string = "magic moose"; my $hash = $c->digest_string( string => $string ); ok( eval { $c->verify_hash( hash => $hash, string => $string, ); }, "verify digest", ); ok( !$@, "no error" ) || diag $@; ok( eval { !$c->verify_hash( hash => $hash, string => "some other string", ); }, "verify bad digest", ); ok( !$@, "no error" ) || diag $@; throws_ok { $c->verify_hash( hash => $hash, string => "some other string", fatal => 1, ), } qr/verification failed/, "verify_hash with fatal => 1"; { my $mac_1 = $c->mac_digest_string( string => "foo", key => "moose" ); my $mac_2 = $c->mac_digest_string( string => "foo", key => "elk" ); cmp_ok( $mac_1, "ne", $mac_2, "mac hashes are ne with different keys" ); } { my $mac_1 = $c->mac_digest_string( string => "foo", key => "moose" ); my $mac_2 = $c->mac_digest_string( string => "bar", key => "moose" ); cmp_ok( $mac_1, "ne", $mac_2, "mac hashes are ne with different messages" ); } { my $mac_1 = $c->mac_digest_string( string => "foo", key => "moose" ); my $mac_2 = $c->mac_digest_string( string => "foo", key => "moose" ); is( $mac_1, $mac_2, "mac hashes are eq when the same" ); } SKIP: { eval { require Digest::MD5 }; skip "Digest::MD5 couldn't be loaded", 3 if $@; skip "Digest::MD5 is the only fallback", 3 if $fallback_digest eq "SHAMD5"; my $md5_hash = $c->digest_string( digest => "MD5", string => $string, ); cmp_ok( $md5_hash, "ne", $hash, "$fallback_digest hash ne MD5 hash" ); ok( !$c->verify_hash( hash => $md5_hash, string => $string, ), "verification fails without same digest", ); ok( $c->verify_hash( hash => $md5_hash, string => $string, digest => "MD5", ), "verification succeeds when MD5", ); } Crypt-Util-0.11/t/encoding.t000644 000765 000024 00000003243 11131763600 017353 0ustar00nothingmuchstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More 'no_plan'; use ok "Crypt::Util"; my $c = Crypt::Util->new; my @strings = ( 'moose', 'foo bar gorch', "\x00 \xff thzxgtj j\$/..,.,\"at {}\$2 1 \n \r \t", # test various paddings ' ', ' ', ' ', ' ', ' ', ); SKIP: { skip "URI::Escape required", @strings * 3 unless eval { require URI::Escape }; skip "MIME::Base64 required", @strings * 3 unless eval { require MIME::Base64 }; skip "MIME::Base64::URLSafe required", @strings * 3 unless eval { require MIME::Base64::URLSafe }; foreach my $string ( @strings ) { my $encoded = $c->encode_string_uri_base64( $string ); my $double_encoded = $c->encode_string_uri_escape( $encoded ); like( $encoded, qr/^[\w\*\-]+$/, "only valid chars" ); is( $encoded, $double_encoded, "no need for further URI escaping" ); is( $c->decode_string_uri_base64($encoded), $string, "round trip" ); } } SKIP: foreach my $encoding (qw/hex uri_escape base64 base32 uri_base64/) { skip "couldn't load $encoding provider", @strings * 2 unless $c->_try_encoding_fallback($encoding); foreach my $string ( @strings ) { ok( defined( my $encoded = $c->encode_string( encoding => $encoding, string => $string ) ), "encode with $encoding" ); is( $c->decode_string( encoding => $encoding, string => $encoded ), $string, "$encoding round trip" ); } } foreach my $encoding (qw/uri alphanumerical printable/) { foreach my $string ( @strings ) { ok( defined( my $encoded = $c->encode_string( encoding => $encoding, string => $string ) ), "encode with $encoding" ); is( $c->decode_string( encoding => $encoding, string => $encoded ), $string, "$encoding round trip" ); } } Crypt-Util-0.11/t/encrypt.t000644 000765 000024 00000002115 11131763600 017246 0ustar00nothingmuchstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Exception; use Crypt::Util; my ( $c, $fallback_cipher ); BEGIN { $c = Crypt::Util->new; $fallback_cipher = eval { $c->fallback_cipher }; plan skip_all => "Couldn't load any cipher" if $@ =~ /^Couldn't load any cipher/; plan 'no_plan'; } my $key = $c->process_key("foo"); ok( length($key), "key has some length" ); cmp_ok( $key, "ne", "foo", "it's a digest of some sort" ); is( $c->process_key("foo", literal_key => 1), "foo", "literal key"); $c->default_use_literal_key(1); is( $c->process_key("foo"), "foo", "literal key from defaults" ); $c->default_use_literal_key(0); foreach my $mode ( qw/stream block CBC CFB OFB Ctr/ ) { SKIP: { skip "$mode not installed ($@)", 1 unless eval { $c->cipher_object( mode => $mode, key => "futz" ) }; my $ciphertext = $c->encrypt_string( key => "moose", string => "dancing", mode => $mode, ); is( $c->decrypt_string( key => "moose", string => $ciphertext, mode => $mode, ), "dancing", "round trip using $mode", ); } } Crypt-Util-0.11/t/exported.t000644 000765 000024 00000001011 11131763600 017406 0ustar00nothingmuchstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More 'no_plan'; use ok 'Crypt::Util' => ( qw/:crypt default_key exported_instance encode_string/, defaults => { key => "moose", encode => 1, }, ); is( default_key, "moose", "default key set through defaults" ); default_key("bar"); is( default_key, "bar", "can be used as a setter, too" ); isa_ok( exported_instance, "Crypt::Util" ); like( encode_string("eagles may soar, but cows don't get sucked into jet engines"), qr/^[a-f0-9]+$/, "encode", ); Crypt-Util-0.11/t/multihash.t000644 000765 000024 00000001567 11131763600 017572 0ustar00nothingmuchstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Exception; use Digest::MultiHash; BEGIN { plan skip_all => "No hash modules found" unless eval { Digest::MultiHash->new } and $@ !~ /^Can't find any digest module/; plan tests => 5; } my $d = Digest::MultiHash->new; isa_ok( $d , "Digest::base" ); $d->width( 8 ); $d->add("foo bar gorch"); my $d2 = Digest::MultiHash->new( width => 8 ); $d2->add("foo bar moose"); my $hash2 = $d2->digest; cmp_ok( $d->digest, "ne", $hash2, "digests differ" ); is( length($hash2), 8, "the hash width is 8" ); throws_ok { my $d = Digest::MultiHash->new( width => 1024, # only 20 bytes in sha1 ); $d->add("foo"); $d->digest; } qr/insufficient.*width/, "Insufficient width causes error"; throws_ok { Digest::MultiHash->new( hashes => [] ); } qr/No digest module specified/, "Can't construct without hashes"; Crypt-Util-0.11/t/tamper.t000644 000765 000024 00000004414 11267443677 017101 0ustar00nothingmuchstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Exception; use Crypt::Util; my $c; BEGIN { $c = Crypt::Util->new; eval { $c->fallback_digest; $c->fallback_cipher; $c->fallback_mac; $c->fallback_authenticated_mode }; plan skip_all => "$1" if $@ =~ /(Couldn't load any \w+)/; plan skip_all => "Couldn't load fallback" if $@; plan 'no_plan'; } $c->default_key("foo"); foreach my $encrypted ( 1, 0 ) { # encrypted not yet supported foreach my $data ( "zemoose gauhy tj lkj GAJE E djjjj laaaa di da dooo", { foo => "bar", gorch => [ qw/very deep/, 1 .. 10 ] }, "\0 bar evil binary string \0 \0\0 foo la \xff foo \0 bar", ) { my $tamper; lives_ok { $tamper = $c->tamper_proof( data => $data, encrypt => $encrypted ) } "tamper proofing lived (" . ($encrypted ? "aead" : "mac signed") .")"; ok( defined($tamper), "got some output" ); unless ( ref $data ) { if ( $encrypted ) { unlike( $tamper, qr/\Q$data/, "tamper proof does not contain the original" ) } else { like( $tamper, qr/\Q$data/, "tamper proof contains the original" ) } } my $thawed; lives_ok { $thawed = $c->thaw_tamper_proof( string => $tamper ) } "tamper proof thaw lived"; ok( defined($thawed), "got some output" ); is_deeply( $thawed, $data, "tamper resistence round trips (" . ($encrypted ? "aead" : "mac signed") .")" ); my $corrupt_tamper = $tamper; substr( $corrupt_tamper, -10, 5 ) ^= "moose"; throws_ok { $c->thaw_tamper_proof( string => $corrupt_tamper ); } qr/verification.*failed/i, "corrupt tamper proof string failed"; my $twaddled_tamper; if ( $encrypted ) { my ( $type, $inner ) = $c->_unpack_tamper_proof($tamper); $twaddled_tamper = $c->decrypt_string( string => $inner ); substr( $twaddled_tamper, -10, 5 ) ^= "moose"; $twaddled_tamper = $c->_pack_tamper_proof($type, $c->encrypt_string( string => $twaddled_tamper )); } else { $twaddled_tamper = $tamper; substr( $twaddled_tamper, -10, 5 ) ^= "moose"; } throws_ok { $c->thaw_tamper_proof( string => $twaddled_tamper ); } qr/verification.*failed/i, "altered tamper proof string failed"; local $Crypt::Util::PACK_FORMAT_VERSION = 2; throws_ok { $c->thaw_tamper_proof( string => $tamper ); } qr/Incompatible packed string/, "version check"; } } Crypt-Util-0.11/lib/Crypt/000755 000765 000024 00000000000 11377441031 017005 5ustar00nothingmuchstaff000000 000000 Crypt-Util-0.11/lib/Digest/000755 000765 000024 00000000000 11377441031 017123 5ustar00nothingmuchstaff000000 000000 Crypt-Util-0.11/lib/Digest/MoreFallbacks.pm000644 000765 000024 00000002706 11267141771 022201 0ustar00nothingmuchstaff000000 000000 #!/usr/bin/perl package Digest::MoreFallbacks; use strict; use warnings; use Digest (); for ( $Digest::MMAP{"RIPEMD-160"} ) { s/PIPE/RIPE/ if defined; } _add_fallback($_, "Crypt::RIPEMD160") for "RIPEMD160", "RIPEMD-160"; foreach my $sha (1, 224, 256, 384, 512) { _add_fallback("SHA$sha", [ "Digest::SHA::PurePerl", $sha ]); _add_fallback("SHA-$sha", [ "Digest::SHA::PurePerl", $sha ]); } _add_fallback(MD5 => $_) for qw(Digest::MD5 Digest::Perl::MD5); sub _add_fallback { my ( $alg, @args ) = @_; my $list; if ( $list = $Digest::MMAP{$alg} ) { unless ( ref $list eq 'ARRAY' ) { $list = $Digest::MMAP{$alg} = [ $list ]; } } else { $list = $Digest::MMAP{$alg} = []; } _append_fallback($list, @args); } sub _append_fallback { my ( $list, $impl ) = @_; if ( ref $impl ) { push @$list, $impl; } else { my %seen; @$list = grep { ref($_) or !$seen{$_}++ } @$list, $impl; } } __PACKAGE__; __END__ =pod =head1 NAME Digest::MoreFallbacks - Provide additional fallbacks in L's MMAP table. =head1 SYNOPSIS use Digest::MoreFallbacks; Digest->new("SHA-1") =head1 DESCRIPTION This module adds entries to L's algorithm to implementation table. The intent is to provide better fallback facilities, including pure Perl modules (L, L), and facilitating for modules that don't match the naming convention (L would have worked if it were named L). =cut Crypt-Util-0.11/lib/Digest/MultiHash.pm000644 000765 000024 00000006724 11267141417 021373 0ustar00nothingmuchstaff000000 000000 #!/usr/bin/perl package Digest::MultiHash; use Moose; extends our @ISA, qw(Digest::base); use Carp qw/croak/; use Digest; use Digest::MoreFallbacks; use Scalar::Util qw/blessed/; use namespace::clean -except => [qw(meta)]; has width => ( isa => "Int", is => "rw", ); has hashes => ( isa => "ArrayRef", is => "ro", required => 1, default => sub { [qw(SHA-1)] }, ); has _digest_objects => ( isa => "ArrayRef", is => "ro", lazy_build => 1, ); sub BUILD { shift->_digest_objects; # force building } sub _call { my ( $self, $method, @args ) = @_; map { $_->$method( @args ) } @{ $self->_digest_objects }; } sub _build__digest_objects { my $self = shift; my @digests = map { blessed($_) ? $_ : Digest->new( ((ref($_)||'') eq "ARRAY") ? @$_ : $_ ) } @{ $self->hashes }; die "No digest module specified" unless @digests; return \@digests; } # MooseX::Clone sub clone { my $self = shift; $self->new( width => $self->width, hashes => $self->hashes, _digest_objects => [ $self->_call("clone") ], ); } sub add { my ( $self, @args ) = @_; $self->_call("add", @args); } sub digest { my $self = shift; my @digests = $self->_call("digest"); my $width = $self->width || length($digests[0]); my $concat = join "", @digests; die "Chosen hashes are insufficient for desired width" if length($concat) < $width; my ( $buf, @pieces ) = unpack "(a$width)*", $concat; $buf ^= $_ for @pieces; return $buf; } __PACKAGE__; __END__ =pod =head1 NAME Digest::MultiHash - XOR based, variable width multiplexing of hashes (a generalized Digest::SV1). =head1 SYNOPSIS use Digest::MultiHash; my $d = Digest::Multihash->new( width => 16, # bytes hashs => ["SHA-512", "Whirlpool"], # see below for arbitrary arguments ); $d->add($data); print $d->hexdigest; =head1 DESCRIPTION This class inherits from L, and provides generalized digest multiplexing. It will multiplex all calls to C to all of it's sub digest objects. Likewise, when the final digest is extracted the digests will be extracted and then XOR'd over eachother according to C. C will default to the width of the first hash if unspecified. C defaults to C for compatibility reasons. This module is useful for generating keys from passphrases, by supplying the desired width and simply making sure there is enough data from the combined hashes. =head1 METHODS See L for the complete API. This module inherits from L. =over 4 =item new This methods accepts a hash reference or an even sized list of parameters named according to the methods. =item add =item digest Compute the hash by calling C on all of the subhashes, splitting the result up into C sized chunk, and then XORing these together. If the result is not aligned on C the result will not be truncated. The shorter string will still be XOR'd with the hash, even if this only affects part of the result. If there are not at least C bytes of data in the output of the combined hashes an error is thrown. =item clone Clones the hash. =item hashes Get the array of hashes to use. Array values in this will be dereferenced before the call to L to allow passing of arbitrary arguments. Blessed objects (of any class) will be used verbatim. The list of hashes cannot be changed after construction. =item width Get/set the byte-width to use. =back =head1 SEE ALSO L, L, L =cut Crypt-Util-0.11/lib/Crypt/Util.pm000644 000765 000024 00000116657 11377441001 020275 0ustar00nothingmuchstaff000000 000000 #!/usr/bin/perl package Crypt::Util; use Moose; our $VERSION = "0.11"; use Digest; use Digest::MoreFallbacks; use Carp qw/croak/; use Sub::Exporter; use Data::OptList; use namespace::clean -except => [qw(meta)]; our %DEFAULT_ACCESSORS = ( mode => { isa => "Str" }, authenticated_mode => { isa => "Str" }, encode => { isa => "Bool" }, encoding => { isa => "Str" }, printable_encoding => { isa => "Str" }, alphanumerical_encoding => { isa => "Str" }, uri_encoding => { isa => "Str" }, digest => { isa => "Str" }, cipher => { isa => "Str" }, mac => { isa => "Str" }, key => { isa => "Str" }, uri_encoding => { isa => "Str" }, printable_encoding => { isa => "Str" }, use_literal_key => { isa => "Bool" }, tamper_proof_unencrypted => { isa => "Bool" }, nonce => { isa => "Str", default => "" }, ); our @DEFAULT_ACCESSORS = keys %DEFAULT_ACCESSORS; my %export_groups = ( 'crypt' => [qw/ encrypt_string decrypt_string authenticated_encrypt_string tamper_proof thaw_tamper_proof cipher_object /], digest => [qw/ digest_string verify_hash verify_digest digest_object mac_digest_string verify_mac /], encoding => [qw/ encode_string decode_string encode_string_hex decode_string_hex encode_string_base64 decode_string_base64 encode_string_base64_wrapped encode_string_base32 decode_string_base32 encode_string_uri_base64 decode_string_uri_base64 encode_string_uri decode_string_uri encode_string_alphanumerical decode_string_alphanumerical encode_string_printable decode_string_printable encode_string_uri_escape decode_string_uri_escape /], params => [ "exported_instance", "disable_fallback", map { "default_$_" } @DEFAULT_ACCESSORS ], ); my %exports = map { $_ => \&__curry_instance } map { @$_ } values %export_groups; Sub::Exporter->import( -setup => { exports => \%exports, groups => \%export_groups, collectors => { defaults => sub { 1 }, }, }); our @KNOWN_AUTHENTICATING_MODES = qw(EAX OCB GCM CWC CCM); # IACBC & IAPM will probably never be implemented our %KNOWN_AUTHENTICATING_MODES = map { $_ => 1 } @KNOWN_AUTHENTICATING_MODES; our %FALLBACK_LISTS = ( mode => [qw/CFB CBC Ctr OFB/], stream_mode => [qw/CFB Ctr OFB/], block_mode => [qw/CBC/], authenticated_mode => [qw/EAX GCM CCM/], # OCB/], OCB is patented cipher => [qw/Rijndael Serpent Twofish RC6 Blowfish RC5/], #authenticated_cipher => [qw/Phelix SOBER-128 Helix/], # not yet ready digest => [qw/SHA-1 SHA-256 RIPEMD160 Whirlpool MD5 Haval256/], mac => [qw/HMAC CMAC/], encoding => [qw/hex/], printable_encoding => [qw/base64 hex/], alphanumerical_encoding => [qw/base32 hex/], uri_encoding => [qw/uri_base64 base32 hex/], ); foreach my $fallback ( keys %FALLBACK_LISTS ) { my @list = @{ $FALLBACK_LISTS{$fallback} }; my $list_method = "fallback_${fallback}_list"; my $list_method_sub = sub { # derefed list accessors my ( $self, @args ) = @_; if ( @args ) { @args = @{ $args[0] } if @args == 1 and (ref($args[0])||'') eq "ARRAY"; $self->{$list_method} = \@args; } @{ $self->{$list_method} || \@list }; }; my $type = ( $fallback =~ /(encoding|mode)/ )[0] || $fallback; my $try = "_try_${type}_fallback"; my $fallback_sub = sub { my $self = shift; $self->_find_fallback( $fallback, $try, $self->$list_method, ) || croak "Couldn't load any $fallback"; }; no strict 'refs'; *{ "fallback_$fallback" } = $fallback_sub; *{ $list_method } = $list_method_sub; } foreach my $attr ( @DEFAULT_ACCESSORS ) { has "default_$attr" => ( is => "rw", predicate => "has_default_$attr", clearer => "clear_default_$attr", ( __PACKAGE__->can("fallback_$attr") ? ( lazy_build => 1, builder => "fallback_$attr", ) : () ), %{ $DEFAULT_ACCESSORS{$attr} }, ); } has disable_fallback => ( isa => "Bool", is => "rw", ); __PACKAGE__->meta->make_immutable if __PACKAGE__->meta->can("make_immutable"); { my %fallback_caches; sub _find_fallback { my ( $self, $key, $test, @list ) = @_; my $cache = $fallback_caches{$key} ||= {}; @list = $list[0] if @list and $self->disable_fallback; foreach my $elem ( @list ) { $cache->{$elem} = $self->$test( $elem ) unless exists $cache->{$elem}; return $elem if $cache->{$elem}; } return; } } sub _try_cipher_fallback { my ( $self, $name ) = @_; $self->_try_loading_module("Crypt::$name"); } sub _try_digest_fallback { my ( $self, $name ) = @_; my $e; { local $@; eval { $self->digest_object( digest => $name ) }; $e = $@; }; return 1 if !$e; ( my $file = $name ) =~ s{::}{/}g; die $e if $e !~ m{^Can't locate Digest/\Q${file}.pm\E in \@INC}; return; } sub _try_mode_fallback { my ( $self, $mode ) = @_; $self->_try_loading_module("Crypt::$mode"); } sub _try_mac_fallback { my ( $self, $mac ) = @_; $self->_try_loading_module("Digest::$mac"); } sub _try_loading_module { my ( $self, $name ) = @_; (my $file = "${name}.pm") =~ s{::}{/}g; my ( $r, $e ); { local $@; $r = eval { require $file }; # yes it's portable $e = $@; }; return $r if $r; die $e if $e !~ /^Can't locate \Q$file\E in \@INC/; return $r; } { my %encoding_module = ( base64 => "MIME::Base64", uri_base64 => "MIME::Base64::URLSafe", base32 => "MIME::Base32", uri_escape => "URI::Escape", ); sub _try_encoding_fallback { my ( $self, $encoding ) = @_; return 1 if $encoding eq "hex"; my $module = $encoding_module{$encoding}; $module =~ s{::}{/}g; $module .= ".pm"; my $e = do { local $@; eval { require $module }; # yes it's portable $@; }; return 1 if !$e; die $e if $e !~ /^Can't locate \Q$module\E in \@INC/; return; } } sub _args (\@;$) { my ( $args, $odd ) = @_; my ( $self, @args ) = @$args; my %params; if ( @args % 2 == 1 ) { croak "The parameters must be an even sized list of key value pairs" unless defined $odd; ( my $odd_value, %params ) = @args; croak "Can't provide the positional param in the named list as well" if exists $params{$odd}; $params{$odd} = $odd_value; } else { %params = @args; } return ( $self, %params ); } sub _process_params { my ( $self, $params, @required ) = @_; foreach my $param ( @required ) { next if exists $params->{$param}; $params->{$param} = $self->_process_param( $param ); } } sub _process_param { my ( $self, $param ) = @_; my $default = "default_$param"; if ( $self->can($default) ) { return $self->$default; } croak "No default value for required parameter '$param'"; } sub cipher_object { my ( $self, %params ) = _args @_; $self->_process_params( \%params, qw/mode/); my $method = "cipher_object_" . lc(my $mode = delete $params{mode}); croak "mode $mode is unsupported" unless $self->can($method); $self->$method( %params ); } sub cipher_object_eax { my ( $self, %params ) = _args @_; $self->_process_params( \%params, qw/cipher nonce/ ); require Crypt::EAX; Crypt::EAX->new( %params, cipher => "Crypt::$params{cipher}", # FIXME take a ref, but Crypt::CFB will barf key => $self->process_key(%params), nonce => $params{nonce}, ); } sub cipher_object_cbc { my ( $self, %params ) = _args @_; $self->_process_params( \%params, qw/cipher/ ); require Crypt::CBC; Crypt::CBC->new( -cipher => $params{cipher}, -key => $self->process_key(%params), ); } sub cipher_object_ofb { my ( $self, %params ) = _args @_; $self->_process_params( \%params, qw/cipher/ ); require Crypt::OFB; my $c = Crypt::OFB->new; $c->padding( Crypt::ECB::PADDING_AUTO() ); $c->key( $self->process_key(%params) ); $c->cipher( $params{cipher} ); return $c; } sub cipher_object_cfb { my ( $self, @args ) = _args @_; require Crypt::CFB; $self->_cipher_object_baurem( "Crypt::CFB", @args ); } sub cipher_object_ctr { my ( $self, @args ) = _args @_; require Crypt::Ctr; $self->_cipher_object_baurem( "Crypt::Ctr", @args ); } sub _cipher_object_baurem { my ( $self, $class, %params ) = @_; my $prefix = "Crypt"; ( $prefix, $params{cipher} ) = ( Digest => delete $params{digest} ) if exists $params{encryption_digest}; $self->_process_params( \%params, qw/cipher/ ); $class->new( $self->process_key(%params), join("::", $prefix, $params{cipher}) ); } use tt; [% FOR mode IN ["stream", "block", "authenticated"] %] sub cipher_object_[% mode %] { my ( $self, @args ) = _args @_; my $mode = $self->_process_param("[% mode %]_mode"); $self->cipher_object( @args, mode => $mode ); } [% END %] no tt; sub process_nonce { my ( $self, %params ) = _args @_, 'nonce'; my $nonce = $self->_process_params( \%params, 'nonce' ); if ( length($nonce) ) { return $nonce; } else { require Data::GUID; Data::GUID->new->as_binary; } } sub process_key { my ( $self, %params ) = _args @_, "key"; if ( $params{literal_key} || $self->default_use_literal_key ) { $self->_process_params( \%params, qw/key/ ); return $params{key}; } else { my $size = $params{key_size}; unless ( $size ) { $self->_process_params( \%params, qw/key cipher/ ); my $cipher = $params{cipher}; my $class = "Crypt::$cipher"; $self->_try_loading_module($class); if ( my $size_method = $class->can("keysize") || $class->can("blocksize") ) { $size = $class->$size_method; } $size ||= $cipher eq "Blowfish" ? 56 : 32; } return $self->digest_string( string => $params{key}, digest => "MultiHash", encode => 0, digest_args => [{ width => $size, hashes => ["SHA-512"], # no need to be overkill, we just need the variable width }], ); } } sub digest_object { my ( $self, %params ) = _args @_; $self->_process_params( \%params, qw/ digest /); Digest->new( $params{digest}, @{ $params{digest_args} || [] } ); } { # this is a hack that gives to Digest::HMAC something that responds to ->new package Crypt::Util::HMACDigestFactory; sub new { my $self = shift; $$self->clone; } sub new_factory { my ( $self, $thing ) = @_; return bless \$thing, $self; } } sub mac_object { my ( $self, %params ) = _args @_; $self->_process_params( \%params, qw/ mac /); my $mac_type = delete $params{mac}; my $method = lc( "mac_object_$mac_type" ); $self->$method( %params ); } sub mac_object_hmac { my ( $self, @args ) = _args @_; my $digest = $self->digest_object(@args); my $digest_factory = Crypt::Util::HMACDigestFactory->new_factory( $digest ); my $key = $self->process_key( literal_key => 1, # Digest::HMAC does it's own key processing, but we let the user force our own key_size => 64, # if the user did force our own, the default key_size is Digest::HMAC's default block size @args, ); require Digest::HMAC; Digest::HMAC->new( $key, $digest_factory, # FIXME hmac_block_size param? ); } sub mac_object_cmac { my ( $self, %params ) = _args @_; my ( $key, $cipher ); if ( ref $params{cipher} ) { $cipher = $params{cipher}; } else { $self->_process_params( \%params, qw(cipher) ); $cipher = "Crypt::" . $params{cipher}; $key = $self->process_key(%params); } require Digest::CMAC; Digest::CMAC->new( $key, $cipher ); } use tt; [% FOR f IN ["en", "de"] %] sub [% f %]crypt_string { my ( $self, %params ) = _args @_, "string"; my $string = delete $params{string}; croak "You must provide the 'string' parameter" unless defined $string; my $c = $self->cipher_object( %params ); [% IF f == "en" %] $self->maybe_encode( $c->encrypt($string), \%params ); [% ELSE %] $c->decrypt( $self->maybe_decode($string, \%params ) ); [% END %] } sub maybe_[% f %]code { my ( $self, $string, $params ) = @_; my $should_encode = exists $params->{[% f %]code} ? $params->{[% f %]code} : exists $params->{encoding} || $self->default_encode; if ( $should_encode ) { return $self->[% f %]code_string( %$params, string => $string, ); } else { return $string; } } [% END %] no tt; sub _digest_string_with_object { my ( $self, $object, %params ) = @_; my $string = delete $params{string}; croak "You must provide the 'string' parameter" unless defined $string; $object->add($string); $self->maybe_encode( $object->digest, \%params ); } sub digest_string { my ( $self, %params ) = _args @_, "string"; my $d = $self->digest_object( %params ); $self->_digest_string_with_object( $d, %params ); } sub mac_digest_string { my ( $self, %params ) = _args @_, "string"; my $d = $self->mac_object( %params ); $self->_digest_string_with_object( $d, %params ); } sub _do_verify_hash { my ( $self, %params ) = _args @_; my $hash = delete $params{hash}; my $fatal = delete $params{fatal}; croak "You must provide the 'string' and 'hash' parameters" unless defined $params{string} and defined $hash; my $meth = $params{digest_method}; return 1 if $hash eq $self->$meth(%params); if ( $fatal ) { croak "Digest verification failed"; } else { return; } } sub verify_hash { my ( $self, @args ) = @_; $self->_do_verify_hash(@args, digest_method => "digest_string"); } sub verify_digest { my ( $self, @args ) = @_; $self->verify_hash(@args); } sub verify_mac { my ( $self, @args ) = @_; $self->_do_verify_hash(@args, digest_method => "mac_digest_string"); } { my @flags = qw/serialized/; sub _flag_hash_to_int { my ( $self, $flags ) = @_; my $bit = 1; my $flags_int = 0; foreach my $flag (@flags) { $flags_int |= $bit if $flags->{$flag}; } continue { $bit *= 2; } return $flags_int; } sub _flag_int_to_hash { my ( $self, $flags ) = @_; my $bit =1; my %flags; foreach my $flag (@flags ) { $flags{$flag} = $flags & $bit; } continue { $bit *= 2; } return wantarray ? %flags : \%flags; } } sub tamper_proof { my ( $self, %params ) = _args @_, "data"; $params{string} = $self->pack_data( %params ); #$params{header} = $self->pack_data( %params, data => $params{header} ) if exists $params{header}; # FIXME this is not yet finished $self->tamper_proof_string( %params ); } sub freeze_data { my ( $self, %params ) = @_; require Storable; Storable::nfreeze($params{data}); } sub thaw_data { my ( $self, %params ) = @_; require Storable; Storable::thaw($params{data}); } sub tamper_proof_string { my ( $self, %params ) = _args @_, "string"; my $encrypted = exists $params{encrypt} ? $params{encrypt} : !$self->default_tamper_proof_unencrypted; my $type = ( $encrypted ? "aead" : "mac" ); my $method = "${type}_tamper_proof_string"; my $string = $self->$method( %params ); return $self->_pack_tamper_proof( $type => $string ); } { my @tamper_proof_types = qw/mac aead/; my %tamper_proof_type; @tamper_proof_type{@tamper_proof_types} = 1 .. @tamper_proof_types; sub _pack_tamper_proof { my ( $self, $type, $proof ) = @_; pack("C a*", $tamper_proof_type{$type}, $proof); } sub _unpack_tamper_proof { my ( $self, $packed ) = @_; my ( $type, $string ) = unpack("C a*", $packed); return ( ($tamper_proof_types[ $type-1 ] || croak "Unknown tamper proofing method"), $string, ); } } sub _authenticated_mode { my ( $self, $params ) = @_; # trust explicit param if ( exists $params->{authenticated_mode} ) { $params->{mode} = delete $params->{authenticated_mode}; return 1; } # check if the explicit param is authenticated if ( exists $params->{mode} ) { # allow overriding if ( exists $params->{mode_is_authenticated} ) { return $params->{mode_is_authenticated}; } if ( $KNOWN_AUTHENTICATING_MODES{uc($params->{mode})} ) { return 1; } else { return; } } $params->{mode} = $self->_process_param('authenticated_mode'); return 1; } sub _pack_hash_and_message { my ( $self, $hash, $message ) = @_; pack("n/a* a*", $hash, $message); } sub _unpack_hash_and_message { my ( $self, $packed ) = @_; unpack("n/a* a*", $packed); } our $PACK_FORMAT_VERSION = 1; sub pack_data { my ( $self, %params ) = _args @_, "data"; $self->_process_params( \%params, qw/ data /); my $data = delete $params{data}; my %flags; if ( ref $data ) { $flags{serialized} = 1; $data = $self->freeze_data( %params, data => $data ); } $self->_pack_version_flags_and_string( $PACK_FORMAT_VERSION, \%flags, $data ); } sub unpack_data { my ( $self, %params ) = _args @_, "data"; $self->_process_params( \%params, qw/ data /); my ( $version, $flags, $data ) = $self->_unpack_version_flags_and_string($params{data}); $self->_packed_string_version_check( $version ); if ( $flags->{serialized} ) { return $self->thaw_data( %params, data => $data ); } else { return $data; } } sub _pack_version_flags_and_string { my ( $self, $version, $flags, $string ) = @_; pack("n n N/a*", $version, $self->_flag_hash_to_int($flags), $string); } sub _unpack_version_flags_and_string { my ( $self, $packed ) = @_; my ( $version, $flags, $string ) = unpack("n n N/a*", $packed); $flags = $self->_flag_int_to_hash($flags); return ( $version, $flags, $string ); } sub authenticated_encrypt_string { my ( $self, %params ) = _args @_, "string"; # FIXME some ciphers are authenticated, but none are implemented in perl yet if ( $self->_authenticated_mode(\%params) ) { $self->_process_params( \%params, qw(nonce) ); # generate a nonce unless one is explicitly provided my $nonce = $self->process_nonce(%params); # FIMXE limit to 64k? # FIXME safely encode an arbitrary header as well #my $header = $params{header}; #$header = '' unless defined $header; return pack("n/a* a*", $nonce, $self->encrypt_string( %params, nonce => $nonce ) ); } else { croak "To use encrypted tamper resistent strings an authenticated encryption mode such as EAX must be selected"; } } sub authenticated_decrypt_string { my ( $self, %params ) = _args @_, "string"; if ( $self->_authenticated_mode(\%params) ) { $self->_process_params( \%params, qw(string) ); my ( $nonce, $string ) = unpack("n/a* a*", $params{string}); return $self->decrypt_string( fatal => 1, %params, nonce => $nonce, string => $string, ); } else { croak "To use encrypted tamper resistent strings an authenticated encryption mode such as EAX must be selected"; } } sub aead_tamper_proof_string { my ( $self, %params ) = _args @_, "string"; $self->authenticated_encrypt_string( %params ); } sub mac_tamper_proof_string { my ( $self, %params ) = _args @_, "string"; my $string = delete $params{string}; croak "You must provide the 'string' parameter" unless defined $string; my $hash = $self->mac_digest_string( %params, encode => 0, string => $string, ); return $self->_pack_hash_and_message( $hash, $string ); } sub thaw_tamper_proof_string { my ( $self, %params ) = _args @_, "string"; my $string = delete $params{string}; croak "You must provide the 'string' parameter" unless defined $string; my ( $type, $message ) = $self->_unpack_tamper_proof($string); my $method = "thaw_tamper_proof_string_$type"; my $packed = $self->$method( %params, string => $message ); } sub thaw_tamper_proof { my ( $self, %params ) = _args @_, "string"; my $packed = $self->thaw_tamper_proof_string(%params); $self->unpack_data(%params, data => $packed); } sub thaw_tamper_proof_string_aead { my ( $self, %params ) = _args @_, "string"; $self->authenticated_decrypt_string( %params ); } sub thaw_tamper_proof_string_mac { my ( $self, %params ) = _args @_, "string"; my $hashed_packed = delete $params{string}; croak "You must provide the 'string' parameter" unless defined $hashed_packed; my ( $hash, $packed ) = $self->_unpack_hash_and_message( $hashed_packed ); return unless $self->verify_mac( fatal => 1, %params, hash => $hash, decode => 0, string => $packed, ); return $packed; } sub _packed_string_version_check { my ( $self, $version ) = @_; croak "Incompatible packed string (I'm version $PACK_FORMAT_VERSION, thawing version $version)" unless $version == $PACK_FORMAT_VERSION; } use tt; [% FOR f IN ["en","de"] %] sub [% f %]code_string { my ( $self, %params ) = _args @_, "string"; my $string = delete $params{string}; croak "You must provide the 'string' parameter" unless defined $string; $self->_process_params( \%params, qw/ encoding /); my $encoding = delete $params{encoding}; croak "Encoding method must be an encoding name" unless $encoding; my $method = "[% f %]code_string_$encoding"; croak "Encoding method $encoding is not supported" unless $self->can($method); $self->$method($string); } [% END %] no tt; sub encode_string_hex { my ( $self, $string ) = @_; unpack("H*", $string); } sub decode_string_hex { my ( $self, $hex ) = @_; pack("H*", $hex ); } sub encode_string_base64 { my ( $self, $string ) = @_; require MIME::Base64; MIME::Base64::encode_base64($string, ""); } sub encode_string_base64_wrapped { my ( $self, $string ) = @_; require MIME::Base64; MIME::Base64::encode_base64($string); } sub decode_string_base64 { my ( $self, $base64 ) = @_; require MIME::Base64; MIME::Base64::decode_base64($base64); } # http://www.dev411.com/blog/2006/10/02/encoding-hashed-uids-base64-vs-hex-vs-base32 sub encode_string_uri_base64 { my ( $self, $string ) = @_; require MIME::Base64::URLSafe; MIME::Base64::URLSafe::encode($string); } sub decode_string_uri_base64 { my ( $self, $base64 ) = @_; require MIME::Base64::URLSafe; MIME::Base64::URLSafe::decode($base64); } sub encode_string_base32 { my ( $self, $string ) = @_; require MIME::Base32; MIME::Base32::encode_rfc3548($string); } sub decode_string_base32 { my ( $self, $base32 ) = @_; require MIME::Base32; MIME::Base32::decode_rfc3548(uc($base32)); } sub encode_string_uri_escape { my ( $self, $string ) = @_; require URI::Escape; URI::Escape::uri_escape($string); } sub decode_string_uri_escape { my ( $self, $uri_escaped ) = @_; require URI::Escape; URI::Escape::uri_unescape($uri_escaped); } use tt; [% FOR symbolic_encoding IN ["uri", "alphanumerical", "printable"] %] [% FOR f IN ["en", "de"] %] sub [% f %]code_string_[% symbolic_encoding %] { my ( $self, $string ) = @_; my $encoding = $self->_process_param("[% symbolic_encoding %]_encoding"); $self->[% f %]code_string( string => $string, encoding => $encoding ); } [% END %] [% END %] no tt; sub exported_instance { my $self = shift; return $self; } sub __curry_instance { my ($class, $method_name, undef, $col) = @_; my $self = $col->{instance} ||= $class->__curry_flavoured_instance($col); sub { $self->$method_name(@_) }; } sub __curry_flavoured_instance { my ( $class, $col ) = @_; my %params; @params{ map { "default_$_" } keys %{ $col->{defaults} } } = values %{ $col->{defaults} }; $class->new( \%params ); } __PACKAGE__; __END__ =pod =head1 NAME Crypt::Util - A lightweight Crypt/Digest convenience API =head1 SYNOPSIS use Crypt::Util; # also has a Sub::Exporter to return functions wrapping a default instance my $util = Crypt::Util->new; $util->default_key("my secret"); # MAC or cipher+digest based tamper resistent encapsulation # (uses Storable on $data if necessary) my $tamper_resistent_string = $util->tamper_proof( $data ); my $verified = $util->thaw_tamper_proof( $untrusted_string, key => "another secret" ); # If the encoding is unspecified, base32 is used # (hex if base32 is unavailable) my $encoded = $util->encode_string( $bytes ); my $hash = $util->digest( $bytes, digest => "md5" ); die "baaaad" unless $util->verify_hash( hash => $hash, data => $bytes, digest => "md5", ); =head1 DESCRIPTION This module provides an easy, intuitive and forgiving API for wielding crypto-fu. The API is designed as a cascade, with rich features built using simpler ones. this means that the option processing is uniform throughout, and the behaviors are generally predictable. Note that L doesn't do any crypto on its own, but delegates the actual work to the various other crypto modules on the CPAN. L merely wraps these modules, providing uniform parameters, and building on top of their polymorphism with higher level features. =head2 Priorities =over 4 =item Ease of use This module is designed to have an easy API to allow easy but responsible use of the more low level Crypt:: and Digest:: modules on CPAN. Therefore, patches to improve ease-of-use are very welcome. =item Pluggability Dependency hell is avoided using a fallback mechanism that tries to choose an algorithm based on an overridable list. For "simple" use install Crypt::Util and your favourite digest, cipher and cipher mode (CBC, CFB, etc). To ensure predictable behavior the fallback behavior can be disabled as necessary. =back =head2 Interoperability To ensure that your hashes and strings are compatible with L deployments on other machines (where different Crypt/Digest modules are available, etc) you should use C. Then either set the default ciphers, or always explicitly state the cipher. If you are only encrypting and decrypting with the same installation, and new cryptographic modules are not being installed, the hashes/ciphertexts should be compatible without disabling fallback. =head1 EXPORTED API B: nothing is exported by default. L also presents an optional exported api using L. Unlike typical exported APIs, there is no class level default instance shared by all the importers, but instead every importer gets its own instance. For example: package A; use Crypt::Util qw/:all/; default_key("moose"); my $ciphertext = encrypt_string($plain); package B; use Crypt::Util qw/:all/; default_key("elk"); my $ciphertext = encrypt_string($plain); In this example every importing package has its own implicit instance, and the C function will in fact not share the value. You can get the instance using the C function, which is just the identity method. The export tags supported are: C (encryption and tamper proofing related functions), C (digest and MAC related functions), C (various encoding and decoding functions), and C which give you functions for handling default values. =head1 METHODS =over 4 =item tamper_proof( [ $data ], %params ) =item thaw_tamper_proof( [ $string ], %params ) =item tamper_proof_string( $string, %params ) =item thaw_tamper_proof_string( $string, %params ) =item aead_tamper_proof_string( [ $string ], %params ) =item mac_tamper_proof_string( [ $string ], %params ) The C method is in an intermittent state, in that the C parameter's API is not completely finalized. It is safer to use C; its API is expected to remain the same in future versions as well. See L for more information about the data types that will be supported in the future. When thawing, the C or C methods will be used, with C defaulting to on unless explicitly disabled in the parameters. =over 4 This method accepts the following parameters: =item * encrypt By default this parameter is true, unless C, has been enabled. A true value implies that all the parameters which are available to C are also available. If a negative value is specified, MAC mode is used, and the additional parameters of C may also be specified to this method. =item * data The data to encrypt. If this is a reference L will be used to serialize the data. See C for details. =back If the string is encrypted then all the parameters of C and C are also available. If the string is not encrypted, then all the parameters of C are also available. =item encrypt_string( [ $string ], %params ) =item decrypt_string( [ $string ], %params ) =item authenticated_encrypt_string( [ $string ], %params ) =item authenticated_decrypt_string( [ $string ], %params ) All of the parameters which may be supplied to C, C and C are also available to these methods. The C variants ensure that an authenticated encryption mode (such as EAX) is used. The following parameters may be used: =over 4 =item * string The string to be en/decrypted can either be supplied first, creating an odd number of arguments, or as a named parameter. =item * nonce The cryptographic nonce to use. Only necessary for encryption, will be packed in the string as part of the message if applicable. =item * header Not yet supported. In the future this will include a header for AEAD (the "associated data" bit of AEAD). =back =item process_key( [ $key ], %params ) The following arguments may be specified: =over 4 =item * literal_key This disables mungung. See also C. =item * key_size Can be used to force a key size, even if the cipher specifies another size. If not specified, the key size chosen will depend =item * cipher Used to determine the key size. =back =item process_nonce( [ $nonce ], %params ) If a nonce is explicitly specified this method returns that, and otherwise uses L to generate a unique binary string for use as a nonce/IV. =item pack_data( [ $data ], %params ) =item unpack_data( [ $data ], %params ) Uses L and C to create a string out of data. L support will be added in the future. The format itself is versioned in order to facilitate future proofing and backwards compatibility. Note that it is not safe to call C on an untrusted string, use C instead (it will authenticate the data and only then perform the potentially unsafe routines). =item cipher_object( %params ) Available parameters are: =over 4 =item * cipher The cipher algorithm to use, e.g. C, C etc. =item * mode The mode of operation. This can be real (C, C, C, C, C) or symbolic (C, C, C). See L for an explanation of this. =back =item cipher_object_eax( %params ) Used by C but accepts additional parameters: =over 4 =item * nonce The nonce is a value that should be unique in order to protect against replay attacks. It also ensures that the same plain text with the same key will produce different ciphertexts. The nonce is not included in the output ciphertext. See C for a convenience method that does include the nonce. =item * header This is additional data to authenticate but not encrypt. See L for more details. The header will not be included in the output ciphertext. =back =item digest_string( [ $string ], %params ) Delegates to C. All parameters which can be used by C may also be used here. The following arguments are available: =over 4 =item * string The string to be digested can either be supplied first, creating an odd number of arguments, or as a named parameter. =back =item verify_digest( %params ) Delegates to C. All parameters which can be used by C may also be used here. The following parameters are accepted: =over 4 =item * hash A string containing the hash to verify. =item * string The digested string. =item * fatal If true, errors will be fatal. The default is false, which means that failures will return undef. =back In addition, the parameters which can be supplied to C may also be supplied to this method. =item digest_object( %params ) =over 4 =item * digest The digest algorithm to use. =back Returns an object using L. =item encode_string( [ $string ], %params ) =item decode_string( [ $string ], %params ) The following parameters are accepted: =over 4 =item * encoding The encoding may be a symbolic type (uri, printable) or a concrete type (none, hex, base64, base32). =back =item mac_digest_string( [ $string ], %param ) Delegates to C. All parameters which can be used by C may also be used here. =over 4 =item * string =back =item verify_mac( %params ) Delegates to C. All parameters which can be used by C may also be used here. The following additional arguments are allowed: =over 4 =item * hash The MAC string to verify. =item * string The digested string. =item * fatal If true, errors will be fatal. The default is false, which means that failures will return undef. =back =item mac_object( %params ) =over 4 =item * mac The MAC algorithm to use. Currently C and C are supported. =back =item maybe_encode =item maybe_decode This method has no external API but is documented for the sake of its shared options. It is delegated to by the various encryption and digest method. =over 4 =item * encode Expects a bool. =item * encoding Expects an algorithm name (symbolic (e.g. C, C), or concrete (e.g. C, C)). =back If C is explicitly supplied it will always determine whether or not the string will be encoded. Otherwise, if C is explicitly supplied then the string will always be encoded using the specified algorithm. If neither is supplied C will be checked to determine whether or not to encode, and C or C will be used to determine the algorithm to use (see L). =item encode_string_alphanumerical( $string ) =item decode_string_alphanumerical( $string ) =item encode_string_uri( $string ) =item decode_string_uri( $string ) =item encode_string_printable( $string ) =item decode_string_printable( $string ) The above methods encode based on a fallback list (see L). The variations denote types of formats: C is letters and numbers only (case insensitive), C is safe for inclusions in URIs (without further escaping), and C contains no control characters or whitespace. =item encode_string_hex( $string ) =item decode_string_hex( $string ) Big endian hexadecimal (C pack format). =item encode_string_uri_escape( $string ) =item decode_string_uri_escape( $string ) L based encoding. =item encode_string_base64( $string ) =item decode_string_base64( $string ) =item encode_string_base64_wrapped( $string ) Requires L. The C variant will introduce line breaks as per the L default>. =item encode_string_uri_base64 =item decode_string_uri_base64 Requires L. Implements the Base64 for URIs. See L. =item encode_string_base32( $string ) =item decode_string_base32( $string ) Requires L. (note- unlike L this is case insensitive). =head1 HANDLING OF DEFAULT VALUES =over 4 =item disable_fallback() When true only the first item from the fallback list will be tried, and if it can't be loaded there will be a fatal error. Enable this to ensure portability. =back For every parameter, there are several methods, where PARAMETER is replaced with the parameter name: =over 4 =item * default_PARAMETER() This accessor is available for the user to override the default value. If set to undef, then C will be consulted instead. B the default values are set to undef unless changed by the user. =item * fallback_PARAMETER() Iterates the C, choosing the first value that is usable (it's provider is available). If C is set to a true value, then only the first value in the fallback list will be tried. =item * fallback_PARAMETER_list() An ordered list of values to try and use as fallbacks. C iterates this list and chooses the first one that works. =back Available parameters are as follows: =over 4 =item * cipher The fallback list is C, C, C, C, C and C. L is the AES winner, the next three are AES finalists, and the last two are well known and widely used. =item * mode The mode in which to use the cipher. The fallback list is C, C, C, and C. =item digest The fallback list is C, C, C, C, C, and C. =item * encoding The fallback list is C (effectively no fallback). =item alphanumerical_encoding The fallback list is C and C. L is required for C encoding. =item * uri_encoding The fallback list is C. =item * printable_encoding The fallback list is C =back =head2 Defaults with no fallbacks The following parameters have a C method, as described in the previous section, but the C methods are not applicable. =over 4 =item * encode Whether or not to encode by default (applies to digests and encryptions). =item * key The key to use. Useful for when you are repeatedly encrypting. =item * nonce The nonce/IV to use for cipher modes that require it. Defaults to the empty string, but note that some methods will generate a nonce for you (e.g. C) if none was provided. =item * use_literal_key Whether or not to not hash the key by default. See C. =item * tamper_proof_unencrypted Whether or not tamper resistent strings are by default unencrypted (just MAC). =back =head2 Subclassing You may safely subclass and override C and C to provide values from configurations. =back =head1 TODO =over 4 =item * Crypt::SaltedHash support =item * EMAC (maybe, the modules are not OO and require refactoring) message authentication mode =item * Bruce Schneier Fact Database L. L =item * Entropy fetching (get N weak/strong bytes, etc) from e.g. OpenSSL bindings, /dev/*random, and EGD. =item * Additional data formats (streams/iterators, filehandles, generalized storable data/string handling for all methods, not just tamper_proof). Streams should also be able to used via a simple push api. =item * IV/nonce/salt support for the various cipher modes, not just EAX (CBC, CCM, GCM, etc) =item * L can do its own cipher modes =head1 SEE ALSO L, L, L, L. =head1 VERSION CONTROL This module is maintained using Darcs. You can get the latest version from L, and use C to commit changes. =head1 AUTHORS Yuval Kogman, Enothingmuch@woobling.orgE Ann Barcomb =head1 COPYRIGHT & LICENSE Copyright 2006-2008 by Yuval Kogman Enothingmuch@woobling.orgE, Ann Barcomb Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =cut Crypt-Util-0.11/lib/Crypt/Util.pmc000644 000765 000024 00000122701 11377441012 020425 0ustar00nothingmuchstaff000000 000000 # Generated by tt 0.02 (Module::Compile 0.20) - do not edit! ################((( 32-bit Checksum Validator III )))################ #line 1 BEGIN { use 5.006; local (*F, $/); ($F = __FILE__) =~ s!c$!!; open(F) or die "Cannot open $F: $!"; binmode(F, ':crlf'); if (unpack('%32N*', $F=readline(*F)) != 0x47C88156) { use Filter::Util::Call; my $f = $F; filter_add(sub { filter_del(); 1 while &filter_read; $_ = $f; 1; })}} #line 1 # 8667e12ea286715fb3e93c82b3356305890112f1 package Crypt::Util; use Moose; our $VERSION = "0.11"; use Digest; use Digest::MoreFallbacks; use Carp qw/croak/; use Sub::Exporter; use Data::OptList; use namespace::clean -except => [qw(meta)]; our %DEFAULT_ACCESSORS = ( mode => { isa => "Str" }, authenticated_mode => { isa => "Str" }, encode => { isa => "Bool" }, encoding => { isa => "Str" }, printable_encoding => { isa => "Str" }, alphanumerical_encoding => { isa => "Str" }, uri_encoding => { isa => "Str" }, digest => { isa => "Str" }, cipher => { isa => "Str" }, mac => { isa => "Str" }, key => { isa => "Str" }, uri_encoding => { isa => "Str" }, printable_encoding => { isa => "Str" }, use_literal_key => { isa => "Bool" }, tamper_proof_unencrypted => { isa => "Bool" }, nonce => { isa => "Str", default => "" }, ); our @DEFAULT_ACCESSORS = keys %DEFAULT_ACCESSORS; my %export_groups = ( 'crypt' => [qw/ encrypt_string decrypt_string authenticated_encrypt_string tamper_proof thaw_tamper_proof cipher_object /], digest => [qw/ digest_string verify_hash verify_digest digest_object mac_digest_string verify_mac /], encoding => [qw/ encode_string decode_string encode_string_hex decode_string_hex encode_string_base64 decode_string_base64 encode_string_base64_wrapped encode_string_base32 decode_string_base32 encode_string_uri_base64 decode_string_uri_base64 encode_string_uri decode_string_uri encode_string_alphanumerical decode_string_alphanumerical encode_string_printable decode_string_printable encode_string_uri_escape decode_string_uri_escape /], params => [ "exported_instance", "disable_fallback", map { "default_$_" } @DEFAULT_ACCESSORS ], ); my %exports = map { $_ => \&__curry_instance } map { @$_ } values %export_groups; Sub::Exporter->import( -setup => { exports => \%exports, groups => \%export_groups, collectors => { defaults => sub { 1 }, }, }); our @KNOWN_AUTHENTICATING_MODES = qw(EAX OCB GCM CWC CCM); # IACBC & IAPM will probably never be implemented our %KNOWN_AUTHENTICATING_MODES = map { $_ => 1 } @KNOWN_AUTHENTICATING_MODES; our %FALLBACK_LISTS = ( mode => [qw/CFB CBC Ctr OFB/], stream_mode => [qw/CFB Ctr OFB/], block_mode => [qw/CBC/], authenticated_mode => [qw/EAX GCM CCM/], # OCB/], OCB is patented cipher => [qw/Rijndael Serpent Twofish RC6 Blowfish RC5/], # fa884d2582f6f05a5ffc6634115076027e7e91e1 digest => [qw/SHA-1 SHA-256 RIPEMD160 Whirlpool MD5 Haval256/], mac => [qw/HMAC CMAC/], encoding => [qw/hex/], printable_encoding => [qw/base64 hex/], alphanumerical_encoding => [qw/base32 hex/], uri_encoding => [qw/uri_base64 base32 hex/], ); foreach my $fallback ( keys %FALLBACK_LISTS ) { my @list = @{ $FALLBACK_LISTS{$fallback} }; my $list_method = "fallback_${fallback}_list"; my $list_method_sub = sub { # derefed list accessors my ( $self, @args ) = @_; if ( @args ) { @args = @{ $args[0] } if @args == 1 and (ref($args[0])||'') eq "ARRAY"; $self->{$list_method} = \@args; } @{ $self->{$list_method} || \@list }; }; my $type = ( $fallback =~ /(encoding|mode)/ )[0] || $fallback; my $try = "_try_${type}_fallback"; my $fallback_sub = sub { my $self = shift; $self->_find_fallback( $fallback, $try, $self->$list_method, ) || croak "Couldn't load any $fallback"; }; no strict 'refs'; *{ "fallback_$fallback" } = $fallback_sub; *{ $list_method } = $list_method_sub; } foreach my $attr ( @DEFAULT_ACCESSORS ) { has "default_$attr" => ( is => "rw", predicate => "has_default_$attr", clearer => "clear_default_$attr", ( __PACKAGE__->can("fallback_$attr") ? ( lazy_build => 1, builder => "fallback_$attr", ) : () ), %{ $DEFAULT_ACCESSORS{$attr} }, ); } has disable_fallback => ( isa => "Bool", is => "rw", ); __PACKAGE__->meta->make_immutable if __PACKAGE__->meta->can("make_immutable"); { my %fallback_caches; sub _find_fallback { my ( $self, $key, $test, @list ) = @_; my $cache = $fallback_caches{$key} ||= {}; @list = $list[0] if @list and $self->disable_fallback; foreach my $elem ( @list ) { $cache->{$elem} = $self->$test( $elem ) unless exists $cache->{$elem}; return $elem if $cache->{$elem}; } return; } } sub _try_cipher_fallback { my ( $self, $name ) = @_; $self->_try_loading_module("Crypt::$name"); } sub _try_digest_fallback { my ( $self, $name ) = @_; my $e; { local $@; eval { $self->digest_object( digest => $name ) }; $e = $@; }; return 1 if !$e; ( my $file = $name ) =~ s{::}{/}g; die $e if $e !~ m{^Can't locate Digest/\Q${file}.pm\E in \@INC}; return; } sub _try_mode_fallback { my ( $self, $mode ) = @_; $self->_try_loading_module("Crypt::$mode"); } sub _try_mac_fallback { my ( $self, $mac ) = @_; $self->_try_loading_module("Digest::$mac"); } sub _try_loading_module { my ( $self, $name ) = @_; (my $file = "${name}.pm") =~ s{::}{/}g; my ( $r, $e ); { local $@; $r = eval { require $file }; # yes it's portable $e = $@; }; return $r if $r; die $e if $e !~ /^Can't locate \Q$file\E in \@INC/; return $r; } { my %encoding_module = ( base64 => "MIME::Base64", uri_base64 => "MIME::Base64::URLSafe", base32 => "MIME::Base32", uri_escape => "URI::Escape", ); sub _try_encoding_fallback { my ( $self, $encoding ) = @_; return 1 if $encoding eq "hex"; my $module = $encoding_module{$encoding}; $module =~ s{::}{/}g; $module .= ".pm"; my $e = do { local $@; eval { require $module }; # yes it's portable $@; }; return 1 if !$e; die $e if $e !~ /^Can't locate \Q$module\E in \@INC/; return; } } sub _args (\@;$) { my ( $args, $odd ) = @_; my ( $self, @args ) = @$args; my %params; if ( @args % 2 == 1 ) { croak "The parameters must be an even sized list of key value pairs" unless defined $odd; ( my $odd_value, %params ) = @args; croak "Can't provide the positional param in the named list as well" if exists $params{$odd}; $params{$odd} = $odd_value; } else { %params = @args; } return ( $self, %params ); } sub _process_params { my ( $self, $params, @required ) = @_; foreach my $param ( @required ) { next if exists $params->{$param}; $params->{$param} = $self->_process_param( $param ); } } sub _process_param { my ( $self, $param ) = @_; my $default = "default_$param"; if ( $self->can($default) ) { return $self->$default; } croak "No default value for required parameter '$param'"; } sub cipher_object { my ( $self, %params ) = _args @_; $self->_process_params( \%params, qw/mode/); my $method = "cipher_object_" . lc(my $mode = delete $params{mode}); croak "mode $mode is unsupported" unless $self->can($method); $self->$method( %params ); } sub cipher_object_eax { my ( $self, %params ) = _args @_; $self->_process_params( \%params, qw/cipher nonce/ ); require Crypt::EAX; Crypt::EAX->new( %params, cipher => "Crypt::$params{cipher}", # FIXME take a ref, but Crypt::CFB will barf key => $self->process_key(%params), nonce => $params{nonce}, ); } sub cipher_object_cbc { my ( $self, %params ) = _args @_; $self->_process_params( \%params, qw/cipher/ ); require Crypt::CBC; Crypt::CBC->new( -cipher => $params{cipher}, -key => $self->process_key(%params), ); } sub cipher_object_ofb { my ( $self, %params ) = _args @_; $self->_process_params( \%params, qw/cipher/ ); require Crypt::OFB; my $c = Crypt::OFB->new; $c->padding( Crypt::ECB::PADDING_AUTO() ); $c->key( $self->process_key(%params) ); $c->cipher( $params{cipher} ); return $c; } sub cipher_object_cfb { my ( $self, @args ) = _args @_; require Crypt::CFB; $self->_cipher_object_baurem( "Crypt::CFB", @args ); } sub cipher_object_ctr { my ( $self, @args ) = _args @_; require Crypt::Ctr; $self->_cipher_object_baurem( "Crypt::Ctr", @args ); } sub _cipher_object_baurem { my ( $self, $class, %params ) = @_; my $prefix = "Crypt"; ( $prefix, $params{cipher} ) = ( Digest => delete $params{digest} ) if exists $params{encryption_digest}; $self->_process_params( \%params, qw/cipher/ ); $class->new( $self->process_key(%params), join("::", $prefix, $params{cipher}) ); } sub cipher_object_stream { my ( $self, @args ) = _args @_; my $mode = $self->_process_param("stream_mode"); $self->cipher_object( @args, mode => $mode ); } sub cipher_object_block { my ( $self, @args ) = _args @_; my $mode = $self->_process_param("block_mode"); $self->cipher_object( @args, mode => $mode ); } sub cipher_object_authenticated { my ( $self, @args ) = _args @_; my $mode = $self->_process_param("authenticated_mode"); $self->cipher_object( @args, mode => $mode ); } sub process_nonce { my ( $self, %params ) = _args @_, 'nonce'; my $nonce = $self->_process_params( \%params, 'nonce' ); if ( length($nonce) ) { return $nonce; } else { require Data::GUID; Data::GUID->new->as_binary; } } sub process_key { my ( $self, %params ) = _args @_, "key"; if ( $params{literal_key} || $self->default_use_literal_key ) { $self->_process_params( \%params, qw/key/ ); return $params{key}; } else { my $size = $params{key_size}; unless ( $size ) { $self->_process_params( \%params, qw/key cipher/ ); my $cipher = $params{cipher}; my $class = "Crypt::$cipher"; $self->_try_loading_module($class); if ( my $size_method = $class->can("keysize") || $class->can("blocksize") ) { $size = $class->$size_method; } $size ||= $cipher eq "Blowfish" ? 56 : 32; } return $self->digest_string( string => $params{key}, digest => "MultiHash", encode => 0, digest_args => [{ width => $size, hashes => ["SHA-512"], # no need to be overkill, we just need the variable width }], ); } } sub digest_object { my ( $self, %params ) = _args @_; $self->_process_params( \%params, qw/ digest /); Digest->new( $params{digest}, @{ $params{digest_args} || [] } ); } { # c423c07872e6e8002ee9c826c602c9e5e9ec705a package Crypt::Util::HMACDigestFactory; sub new { my $self = shift; $$self->clone; } sub new_factory { my ( $self, $thing ) = @_; return bless \$thing, $self; } } sub mac_object { my ( $self, %params ) = _args @_; $self->_process_params( \%params, qw/ mac /); my $mac_type = delete $params{mac}; my $method = lc( "mac_object_$mac_type" ); $self->$method( %params ); } sub mac_object_hmac { my ( $self, @args ) = _args @_; my $digest = $self->digest_object(@args); my $digest_factory = Crypt::Util::HMACDigestFactory->new_factory( $digest ); my $key = $self->process_key( literal_key => 1, # Digest::HMAC does it's own key processing, but we let the user force our own key_size => 64, # if the user did force our own, the default key_size is Digest::HMAC's default block size @args, ); require Digest::HMAC; Digest::HMAC->new( $key, $digest_factory, # 8f6ca5a32f36f2311a153d671093109b46db764e ); } sub mac_object_cmac { my ( $self, %params ) = _args @_; my ( $key, $cipher ); if ( ref $params{cipher} ) { $cipher = $params{cipher}; } else { $self->_process_params( \%params, qw(cipher) ); $cipher = "Crypt::" . $params{cipher}; $key = $self->process_key(%params); } require Digest::CMAC; Digest::CMAC->new( $key, $cipher ); } sub encrypt_string { my ( $self, %params ) = _args @_, "string"; my $string = delete $params{string}; croak "You must provide the 'string' parameter" unless defined $string; my $c = $self->cipher_object( %params ); $self->maybe_encode( $c->encrypt($string), \%params ); } sub maybe_encode { my ( $self, $string, $params ) = @_; my $should_encode = exists $params->{encode} ? $params->{encode} : exists $params->{encoding} || $self->default_encode; if ( $should_encode ) { return $self->encode_string( %$params, string => $string, ); } else { return $string; } } sub decrypt_string { my ( $self, %params ) = _args @_, "string"; my $string = delete $params{string}; croak "You must provide the 'string' parameter" unless defined $string; my $c = $self->cipher_object( %params ); $c->decrypt( $self->maybe_decode($string, \%params ) ); } sub maybe_decode { my ( $self, $string, $params ) = @_; my $should_encode = exists $params->{decode} ? $params->{decode} : exists $params->{encoding} || $self->default_encode; if ( $should_encode ) { return $self->decode_string( %$params, string => $string, ); } else { return $string; } } sub _digest_string_with_object { my ( $self, $object, %params ) = @_; my $string = delete $params{string}; croak "You must provide the 'string' parameter" unless defined $string; $object->add($string); $self->maybe_encode( $object->digest, \%params ); } sub digest_string { my ( $self, %params ) = _args @_, "string"; my $d = $self->digest_object( %params ); $self->_digest_string_with_object( $d, %params ); } sub mac_digest_string { my ( $self, %params ) = _args @_, "string"; my $d = $self->mac_object( %params ); $self->_digest_string_with_object( $d, %params ); } sub _do_verify_hash { my ( $self, %params ) = _args @_; my $hash = delete $params{hash}; my $fatal = delete $params{fatal}; croak "You must provide the 'string' and 'hash' parameters" unless defined $params{string} and defined $hash; my $meth = $params{digest_method}; return 1 if $hash eq $self->$meth(%params); if ( $fatal ) { croak "Digest verification failed"; } else { return; } } sub verify_hash { my ( $self, @args ) = @_; $self->_do_verify_hash(@args, digest_method => "digest_string"); } sub verify_digest { my ( $self, @args ) = @_; $self->verify_hash(@args); } sub verify_mac { my ( $self, @args ) = @_; $self->_do_verify_hash(@args, digest_method => "mac_digest_string"); } { my @flags = qw/serialized/; sub _flag_hash_to_int { my ( $self, $flags ) = @_; my $bit = 1; my $flags_int = 0; foreach my $flag (@flags) { $flags_int |= $bit if $flags->{$flag}; } continue { $bit *= 2; } return $flags_int; } sub _flag_int_to_hash { my ( $self, $flags ) = @_; my $bit =1; my %flags; foreach my $flag (@flags ) { $flags{$flag} = $flags & $bit; } continue { $bit *= 2; } return wantarray ? %flags : \%flags; } } sub tamper_proof { my ( $self, %params ) = _args @_, "data"; $params{string} = $self->pack_data( %params ); # 1f109116c3860903aa093cd9aa88faff4b02e021 $self->tamper_proof_string( %params ); } sub freeze_data { my ( $self, %params ) = @_; require Storable; Storable::nfreeze($params{data}); } sub thaw_data { my ( $self, %params ) = @_; require Storable; Storable::thaw($params{data}); } sub tamper_proof_string { my ( $self, %params ) = _args @_, "string"; my $encrypted = exists $params{encrypt} ? $params{encrypt} : !$self->default_tamper_proof_unencrypted; my $type = ( $encrypted ? "aead" : "mac" ); my $method = "${type}_tamper_proof_string"; my $string = $self->$method( %params ); return $self->_pack_tamper_proof( $type => $string ); } { my @tamper_proof_types = qw/mac aead/; my %tamper_proof_type; @tamper_proof_type{@tamper_proof_types} = 1 .. @tamper_proof_types; sub _pack_tamper_proof { my ( $self, $type, $proof ) = @_; pack("C a*", $tamper_proof_type{$type}, $proof); } sub _unpack_tamper_proof { my ( $self, $packed ) = @_; my ( $type, $string ) = unpack("C a*", $packed); return ( ($tamper_proof_types[ $type-1 ] || croak "Unknown tamper proofing method"), $string, ); } } sub _authenticated_mode { my ( $self, $params ) = @_; # d8ca7f81e88c105a34bbdfeca3f345ae6b895ab4 if ( exists $params->{authenticated_mode} ) { $params->{mode} = delete $params->{authenticated_mode}; return 1; } # 0f84e32ca8a994cc47b73f87ebe2255970458187 if ( exists $params->{mode} ) { # 90064c4d2aeb8499c4f9c733a18ef416b8d667bf if ( exists $params->{mode_is_authenticated} ) { return $params->{mode_is_authenticated}; } if ( $KNOWN_AUTHENTICATING_MODES{uc($params->{mode})} ) { return 1; } else { return; } } $params->{mode} = $self->_process_param('authenticated_mode'); return 1; } sub _pack_hash_and_message { my ( $self, $hash, $message ) = @_; pack("n/a* a*", $hash, $message); } sub _unpack_hash_and_message { my ( $self, $packed ) = @_; unpack("n/a* a*", $packed); } our $PACK_FORMAT_VERSION = 1; sub pack_data { my ( $self, %params ) = _args @_, "data"; $self->_process_params( \%params, qw/ data /); my $data = delete $params{data}; my %flags; if ( ref $data ) { $flags{serialized} = 1; $data = $self->freeze_data( %params, data => $data ); } $self->_pack_version_flags_and_string( $PACK_FORMAT_VERSION, \%flags, $data ); } sub unpack_data { my ( $self, %params ) = _args @_, "data"; $self->_process_params( \%params, qw/ data /); my ( $version, $flags, $data ) = $self->_unpack_version_flags_and_string($params{data}); $self->_packed_string_version_check( $version ); if ( $flags->{serialized} ) { return $self->thaw_data( %params, data => $data ); } else { return $data; } } sub _pack_version_flags_and_string { my ( $self, $version, $flags, $string ) = @_; pack("n n N/a*", $version, $self->_flag_hash_to_int($flags), $string); } sub _unpack_version_flags_and_string { my ( $self, $packed ) = @_; my ( $version, $flags, $string ) = unpack("n n N/a*", $packed); $flags = $self->_flag_int_to_hash($flags); return ( $version, $flags, $string ); } sub authenticated_encrypt_string { my ( $self, %params ) = _args @_, "string"; # 0d10af4c2d455ed7ab4f4524fbbd8fb8a81e3c6b if ( $self->_authenticated_mode(\%params) ) { $self->_process_params( \%params, qw(nonce) ); # d338aed66b1330e2c735ee56ba65fead37360041 my $nonce = $self->process_nonce(%params); # FIMXE limit to 64k? # 24b22e09d92227262d2f8edb54dbae1559118a51 return pack("n/a* a*", $nonce, $self->encrypt_string( %params, nonce => $nonce ) ); } else { croak "To use encrypted tamper resistent strings an authenticated encryption mode such as EAX must be selected"; } } sub authenticated_decrypt_string { my ( $self, %params ) = _args @_, "string"; if ( $self->_authenticated_mode(\%params) ) { $self->_process_params( \%params, qw(string) ); my ( $nonce, $string ) = unpack("n/a* a*", $params{string}); return $self->decrypt_string( fatal => 1, %params, nonce => $nonce, string => $string, ); } else { croak "To use encrypted tamper resistent strings an authenticated encryption mode such as EAX must be selected"; } } sub aead_tamper_proof_string { my ( $self, %params ) = _args @_, "string"; $self->authenticated_encrypt_string( %params ); } sub mac_tamper_proof_string { my ( $self, %params ) = _args @_, "string"; my $string = delete $params{string}; croak "You must provide the 'string' parameter" unless defined $string; my $hash = $self->mac_digest_string( %params, encode => 0, string => $string, ); return $self->_pack_hash_and_message( $hash, $string ); } sub thaw_tamper_proof_string { my ( $self, %params ) = _args @_, "string"; my $string = delete $params{string}; croak "You must provide the 'string' parameter" unless defined $string; my ( $type, $message ) = $self->_unpack_tamper_proof($string); my $method = "thaw_tamper_proof_string_$type"; my $packed = $self->$method( %params, string => $message ); } sub thaw_tamper_proof { my ( $self, %params ) = _args @_, "string"; my $packed = $self->thaw_tamper_proof_string(%params); $self->unpack_data(%params, data => $packed); } sub thaw_tamper_proof_string_aead { my ( $self, %params ) = _args @_, "string"; $self->authenticated_decrypt_string( %params ); } sub thaw_tamper_proof_string_mac { my ( $self, %params ) = _args @_, "string"; my $hashed_packed = delete $params{string}; croak "You must provide the 'string' parameter" unless defined $hashed_packed; my ( $hash, $packed ) = $self->_unpack_hash_and_message( $hashed_packed ); return unless $self->verify_mac( fatal => 1, %params, hash => $hash, decode => 0, string => $packed, ); return $packed; } sub _packed_string_version_check { my ( $self, $version ) = @_; croak "Incompatible packed string (I'm version $PACK_FORMAT_VERSION, thawing version $version)" unless $version == $PACK_FORMAT_VERSION; } sub encode_string { my ( $self, %params ) = _args @_, "string"; my $string = delete $params{string}; croak "You must provide the 'string' parameter" unless defined $string; $self->_process_params( \%params, qw/ encoding /); my $encoding = delete $params{encoding}; croak "Encoding method must be an encoding name" unless $encoding; my $method = "encode_string_$encoding"; croak "Encoding method $encoding is not supported" unless $self->can($method); $self->$method($string); } sub decode_string { my ( $self, %params ) = _args @_, "string"; my $string = delete $params{string}; croak "You must provide the 'string' parameter" unless defined $string; $self->_process_params( \%params, qw/ encoding /); my $encoding = delete $params{encoding}; croak "Encoding method must be an encoding name" unless $encoding; my $method = "decode_string_$encoding"; croak "Encoding method $encoding is not supported" unless $self->can($method); $self->$method($string); } sub encode_string_hex { my ( $self, $string ) = @_; unpack("H*", $string); } sub decode_string_hex { my ( $self, $hex ) = @_; pack("H*", $hex ); } sub encode_string_base64 { my ( $self, $string ) = @_; require MIME::Base64; MIME::Base64::encode_base64($string, ""); } sub encode_string_base64_wrapped { my ( $self, $string ) = @_; require MIME::Base64; MIME::Base64::encode_base64($string); } sub decode_string_base64 { my ( $self, $base64 ) = @_; require MIME::Base64; MIME::Base64::decode_base64($base64); } # 246d37740a5c4c6a218f83be4355351b9fb8bdbd sub encode_string_uri_base64 { my ( $self, $string ) = @_; require MIME::Base64::URLSafe; MIME::Base64::URLSafe::encode($string); } sub decode_string_uri_base64 { my ( $self, $base64 ) = @_; require MIME::Base64::URLSafe; MIME::Base64::URLSafe::decode($base64); } sub encode_string_base32 { my ( $self, $string ) = @_; require MIME::Base32; MIME::Base32::encode_rfc3548($string); } sub decode_string_base32 { my ( $self, $base32 ) = @_; require MIME::Base32; MIME::Base32::decode_rfc3548(uc($base32)); } sub encode_string_uri_escape { my ( $self, $string ) = @_; require URI::Escape; URI::Escape::uri_escape($string); } sub decode_string_uri_escape { my ( $self, $uri_escaped ) = @_; require URI::Escape; URI::Escape::uri_unescape($uri_escaped); } sub encode_string_uri { my ( $self, $string ) = @_; my $encoding = $self->_process_param("uri_encoding"); $self->encode_string( string => $string, encoding => $encoding ); } sub decode_string_uri { my ( $self, $string ) = @_; my $encoding = $self->_process_param("uri_encoding"); $self->decode_string( string => $string, encoding => $encoding ); } sub encode_string_alphanumerical { my ( $self, $string ) = @_; my $encoding = $self->_process_param("alphanumerical_encoding"); $self->encode_string( string => $string, encoding => $encoding ); } sub decode_string_alphanumerical { my ( $self, $string ) = @_; my $encoding = $self->_process_param("alphanumerical_encoding"); $self->decode_string( string => $string, encoding => $encoding ); } sub encode_string_printable { my ( $self, $string ) = @_; my $encoding = $self->_process_param("printable_encoding"); $self->encode_string( string => $string, encoding => $encoding ); } sub decode_string_printable { my ( $self, $string ) = @_; my $encoding = $self->_process_param("printable_encoding"); $self->decode_string( string => $string, encoding => $encoding ); } sub exported_instance { my $self = shift; return $self; } sub __curry_instance { my ($class, $method_name, undef, $col) = @_; my $self = $col->{instance} ||= $class->__curry_flavoured_instance($col); sub { $self->$method_name(@_) }; } sub __curry_flavoured_instance { my ( $class, $col ) = @_; my %params; @params{ map { "default_$_" } keys %{ $col->{defaults} } } = values %{ $col->{defaults} }; $class->new( \%params ); } __PACKAGE__; __END__ =pod =head1 NAME Crypt::Util - A lightweight Crypt/Digest convenience API =head1 SYNOPSIS use Crypt::Util; # also has a Sub::Exporter to return functions wrapping a default instance my $util = Crypt::Util->new; $util->default_key("my secret"); # MAC or cipher+digest based tamper resistent encapsulation # (uses Storable on $data if necessary) my $tamper_resistent_string = $util->tamper_proof( $data ); my $verified = $util->thaw_tamper_proof( $untrusted_string, key => "another secret" ); # If the encoding is unspecified, base32 is used # (hex if base32 is unavailable) my $encoded = $util->encode_string( $bytes ); my $hash = $util->digest( $bytes, digest => "md5" ); die "baaaad" unless $util->verify_hash( hash => $hash, data => $bytes, digest => "md5", ); =head1 DESCRIPTION This module provides an easy, intuitive and forgiving API for wielding crypto-fu. The API is designed as a cascade, with rich features built using simpler ones. this means that the option processing is uniform throughout, and the behaviors are generally predictable. Note that L doesn't do any crypto on its own, but delegates the actual work to the various other crypto modules on the CPAN. L merely wraps these modules, providing uniform parameters, and building on top of their polymorphism with higher level features. =head2 Priorities =over 4 =item Ease of use This module is designed to have an easy API to allow easy but responsible use of the more low level Crypt:: and Digest:: modules on CPAN. Therefore, patches to improve ease-of-use are very welcome. =item Pluggability Dependency hell is avoided using a fallback mechanism that tries to choose an algorithm based on an overridable list. For "simple" use install Crypt::Util and your favourite digest, cipher and cipher mode (CBC, CFB, etc). To ensure predictable behavior the fallback behavior can be disabled as necessary. =back =head2 Interoperability To ensure that your hashes and strings are compatible with L deployments on other machines (where different Crypt/Digest modules are available, etc) you should use C. Then either set the default ciphers, or always explicitly state the cipher. If you are only encrypting and decrypting with the same installation, and new cryptographic modules are not being installed, the hashes/ciphertexts should be compatible without disabling fallback. =head1 EXPORTED API B: nothing is exported by default. L also presents an optional exported api using L. Unlike typical exported APIs, there is no class level default instance shared by all the importers, but instead every importer gets its own instance. For example: package A; use Crypt::Util qw/:all/; default_key("moose"); my $ciphertext = encrypt_string($plain); package B; use Crypt::Util qw/:all/; default_key("elk"); my $ciphertext = encrypt_string($plain); In this example every importing package has its own implicit instance, and the C function will in fact not share the value. You can get the instance using the C function, which is just the identity method. The export tags supported are: C (encryption and tamper proofing related functions), C (digest and MAC related functions), C (various encoding and decoding functions), and C which give you functions for handling default values. =head1 METHODS =over 4 =item tamper_proof( [ $data ], %params ) =item thaw_tamper_proof( [ $string ], %params ) =item tamper_proof_string( $string, %params ) =item thaw_tamper_proof_string( $string, %params ) =item aead_tamper_proof_string( [ $string ], %params ) =item mac_tamper_proof_string( [ $string ], %params ) The C method is in an intermittent state, in that the C parameter's API is not completely finalized. It is safer to use C; its API is expected to remain the same in future versions as well. See L for more information about the data types that will be supported in the future. When thawing, the C or C methods will be used, with C defaulting to on unless explicitly disabled in the parameters. =over 4 This method accepts the following parameters: =item * encrypt By default this parameter is true, unless C, has been enabled. A true value implies that all the parameters which are available to C are also available. If a negative value is specified, MAC mode is used, and the additional parameters of C may also be specified to this method. =item * data The data to encrypt. If this is a reference L will be used to serialize the data. See C for details. =back If the string is encrypted then all the parameters of C and C are also available. If the string is not encrypted, then all the parameters of C are also available. =item encrypt_string( [ $string ], %params ) =item decrypt_string( [ $string ], %params ) =item authenticated_encrypt_string( [ $string ], %params ) =item authenticated_decrypt_string( [ $string ], %params ) All of the parameters which may be supplied to C, C and C are also available to these methods. The C variants ensure that an authenticated encryption mode (such as EAX) is used. The following parameters may be used: =over 4 =item * string The string to be en/decrypted can either be supplied first, creating an odd number of arguments, or as a named parameter. =item * nonce The cryptographic nonce to use. Only necessary for encryption, will be packed in the string as part of the message if applicable. =item * header Not yet supported. In the future this will include a header for AEAD (the "associated data" bit of AEAD). =back =item process_key( [ $key ], %params ) The following arguments may be specified: =over 4 =item * literal_key This disables mungung. See also C. =item * key_size Can be used to force a key size, even if the cipher specifies another size. If not specified, the key size chosen will depend =item * cipher Used to determine the key size. =back =item process_nonce( [ $nonce ], %params ) If a nonce is explicitly specified this method returns that, and otherwise uses L to generate a unique binary string for use as a nonce/IV. =item pack_data( [ $data ], %params ) =item unpack_data( [ $data ], %params ) Uses L and C to create a string out of data. L support will be added in the future. The format itself is versioned in order to facilitate future proofing and backwards compatibility. Note that it is not safe to call C on an untrusted string, use C instead (it will authenticate the data and only then perform the potentially unsafe routines). =item cipher_object( %params ) Available parameters are: =over 4 =item * cipher The cipher algorithm to use, e.g. C, C etc. =item * mode The mode of operation. This can be real (C, C, C, C, C) or symbolic (C, C, C). See L for an explanation of this. =back =item cipher_object_eax( %params ) Used by C but accepts additional parameters: =over 4 =item * nonce The nonce is a value that should be unique in order to protect against replay attacks. It also ensures that the same plain text with the same key will produce different ciphertexts. The nonce is not included in the output ciphertext. See C for a convenience method that does include the nonce. =item * header This is additional data to authenticate but not encrypt. See L for more details. The header will not be included in the output ciphertext. =back =item digest_string( [ $string ], %params ) Delegates to C. All parameters which can be used by C may also be used here. The following arguments are available: =over 4 =item * string The string to be digested can either be supplied first, creating an odd number of arguments, or as a named parameter. =back =item verify_digest( %params ) Delegates to C. All parameters which can be used by C may also be used here. The following parameters are accepted: =over 4 =item * hash A string containing the hash to verify. =item * string The digested string. =item * fatal If true, errors will be fatal. The default is false, which means that failures will return undef. =back In addition, the parameters which can be supplied to C may also be supplied to this method. =item digest_object( %params ) =over 4 =item * digest The digest algorithm to use. =back Returns an object using L. =item encode_string( [ $string ], %params ) =item decode_string( [ $string ], %params ) The following parameters are accepted: =over 4 =item * encoding The encoding may be a symbolic type (uri, printable) or a concrete type (none, hex, base64, base32). =back =item mac_digest_string( [ $string ], %param ) Delegates to C. All parameters which can be used by C may also be used here. =over 4 =item * string =back =item verify_mac( %params ) Delegates to C. All parameters which can be used by C may also be used here. The following additional arguments are allowed: =over 4 =item * hash The MAC string to verify. =item * string The digested string. =item * fatal If true, errors will be fatal. The default is false, which means that failures will return undef. =back =item mac_object( %params ) =over 4 =item * mac The MAC algorithm to use. Currently C and C are supported. =back =item maybe_encode =item maybe_decode This method has no external API but is documented for the sake of its shared options. It is delegated to by the various encryption and digest method. =over 4 =item * encode Expects a bool. =item * encoding Expects an algorithm name (symbolic (e.g. C, C), or concrete (e.g. C, C)). =back If C is explicitly supplied it will always determine whether or not the string will be encoded. Otherwise, if C is explicitly supplied then the string will always be encoded using the specified algorithm. If neither is supplied C will be checked to determine whether or not to encode, and C or C will be used to determine the algorithm to use (see L). =item encode_string_alphanumerical( $string ) =item decode_string_alphanumerical( $string ) =item encode_string_uri( $string ) =item decode_string_uri( $string ) =item encode_string_printable( $string ) =item decode_string_printable( $string ) The above methods encode based on a fallback list (see L). The variations denote types of formats: C is letters and numbers only (case insensitive), C is safe for inclusions in URIs (without further escaping), and C contains no control characters or whitespace. =item encode_string_hex( $string ) =item decode_string_hex( $string ) Big endian hexadecimal (C pack format). =item encode_string_uri_escape( $string ) =item decode_string_uri_escape( $string ) L based encoding. =item encode_string_base64( $string ) =item decode_string_base64( $string ) =item encode_string_base64_wrapped( $string ) Requires L. The C variant will introduce line breaks as per the L default>. =item encode_string_uri_base64 =item decode_string_uri_base64 Requires L. Implements the Base64 for URIs. See L. =item encode_string_base32( $string ) =item decode_string_base32( $string ) Requires L. (note- unlike L this is case insensitive). =head1 HANDLING OF DEFAULT VALUES =over 4 =item disable_fallback() When true only the first item from the fallback list will be tried, and if it can't be loaded there will be a fatal error. Enable this to ensure portability. =back For every parameter, there are several methods, where PARAMETER is replaced with the parameter name: =over 4 =item * default_PARAMETER() This accessor is available for the user to override the default value. If set to undef, then C will be consulted instead. B the default values are set to undef unless changed by the user. =item * fallback_PARAMETER() Iterates the C, choosing the first value that is usable (it's provider is available). If C is set to a true value, then only the first value in the fallback list will be tried. =item * fallback_PARAMETER_list() An ordered list of values to try and use as fallbacks. C iterates this list and chooses the first one that works. =back Available parameters are as follows: =over 4 =item * cipher The fallback list is C, C, C, C, C and C. L is the AES winner, the next three are AES finalists, and the last two are well known and widely used. =item * mode The mode in which to use the cipher. The fallback list is C, C, C, and C. =item digest The fallback list is C, C, C, C, C, and C. =item * encoding The fallback list is C (effectively no fallback). =item alphanumerical_encoding The fallback list is C and C. L is required for C encoding. =item * uri_encoding The fallback list is C. =item * printable_encoding The fallback list is C =back =head2 Defaults with no fallbacks The following parameters have a C method, as described in the previous section, but the C methods are not applicable. =over 4 =item * encode Whether or not to encode by default (applies to digests and encryptions). =item * key The key to use. Useful for when you are repeatedly encrypting. =item * nonce The nonce/IV to use for cipher modes that require it. Defaults to the empty string, but note that some methods will generate a nonce for you (e.g. C) if none was provided. =item * use_literal_key Whether or not to not hash the key by default. See C. =item * tamper_proof_unencrypted Whether or not tamper resistent strings are by default unencrypted (just MAC). =back =head2 Subclassing You may safely subclass and override C and C to provide values from configurations. =back =head1 TODO =over 4 =item * Crypt::SaltedHash support =item * EMAC (maybe, the modules are not OO and require refactoring) message authentication mode =item * Bruce Schneier Fact Database L. L =item * Entropy fetching (get N weak/strong bytes, etc) from e.g. OpenSSL bindings, /dev/*random, and EGD. =item * Additional data formats (streams/iterators, filehandles, generalized storable data/string handling for all methods, not just tamper_proof). Streams should also be able to used via a simple push api. =item * IV/nonce/salt support for the various cipher modes, not just EAX (CBC, CCM, GCM, etc) =item * L can do its own cipher modes =head1 SEE ALSO L, L, L, L. =head1 VERSION CONTROL This module is maintained using Darcs. You can get the latest version from L, and use C to commit changes. =head1 AUTHORS Yuval Kogman, Enothingmuch@woobling.orgE Ann Barcomb =head1 COPYRIGHT & LICENSE Copyright 2006-2008 by Yuval Kogman Enothingmuch@woobling.orgE, Ann Barcomb Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =cut Crypt-Util-0.11/inc/Module/000755 000765 000024 00000000000 11377441031 017134 5ustar00nothingmuchstaff000000 000000 Crypt-Util-0.11/inc/Module/Install/000755 000765 000024 00000000000 11377441031 020542 5ustar00nothingmuchstaff000000 000000 Crypt-Util-0.11/inc/Module/Install.pm000644 000765 000024 00000026371 11377441022 021111 0ustar00nothingmuchstaff000000 000000 #line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use FindBin; 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 = '0.95'; # 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} ) { 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"}; } *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{"$self->{file}"}; delete $INC{"$self->{path}.pm"}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; 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 ) { *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2010 Adam Kennedy. Crypt-Util-0.11/inc/Module/Install/Base.pm000644 000765 000024 00000001766 11377441022 021764 0ustar00nothingmuchstaff000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '0.95'; } # 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->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 154 Crypt-Util-0.11/inc/Module/Install/Can.pm000644 000765 000024 00000003333 11377441022 021603 0ustar00nothingmuchstaff000000 000000 #line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.95'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 Crypt-Util-0.11/inc/Module/Install/Fetch.pm000644 000765 000024 00000004627 11377441022 022142 0ustar00nothingmuchstaff000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.95'; @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; Crypt-Util-0.11/inc/Module/Install/Makefile.pm000644 000765 000024 00000026220 11377441022 022617 0ustar00nothingmuchstaff000000 000000 #line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.95'; @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} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } my %test_dir = (); sub _wanted_t { /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; } sub tests_recursive { my $self = shift; if ( $self->tests ) { die "tests_recursive will not work if tests are already defined"; } my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } %test_dir = (); require File::Find; File::Find::find( \&_wanted_t, $dir ); if ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { File::Find::find( \&_wanted_t, 'xt' ); } $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT $DB::single = 1; if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( -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 my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $build_prereq->{$file}; #Delete from build prereqs only } } 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: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $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; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; 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 531 Crypt-Util-0.11/inc/Module/Install/Metadata.pm000644 000765 000024 00000041000 11377441022 022613 0ustar00nothingmuchstaff000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.95'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', 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()' ); $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } 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) ); } 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"; } } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:licen[cs]e|licensing)\b.*?) (=head \d.*|=cut.*|)\z /ixms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:copyrights?|legal)\b.*?) (=head \d.*|=cut.*|)\z /ixms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( 'under the same (?:terms|license) as (?:perl|the perl 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, 'BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 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; } } } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( \Qhttp://rt.cpan.org/\E[^>]+| \Qhttp://github.com/\E[\w_]+/[\w_]+/issues| \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Crypt-Util-0.11/inc/Module/Install/Win32.pm000644 000765 000024 00000003403 11377441022 022002 0ustar00nothingmuchstaff000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.95'; @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; Crypt-Util-0.11/inc/Module/Install/WriteAll.pm000644 000765 000024 00000002377 11377441022 022634 0ustar00nothingmuchstaff000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.95';; @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;