From: Vincent Pit Date: Fri, 26 May 2017 15:00:52 +0000 (+0200) Subject: This is 0.01 X-Git-Tag: v0.01^0 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FHash-Normalize.git;a=commitdiff_plain;h=6f74ed5c3c28cff3671169c652710dca831ccf35 This is 0.01 --- 6f74ed5c3c28cff3671169c652710dca831ccf35 diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..d29ffab --- /dev/null +++ b/.gitignore @@ -0,0 +1,28 @@ +blib* +pm_to_blib* + +Makefile +Makefile.old +Build +_build* + +MYMETA.json +MYMETA.yml + +*.tar.gz +Hash-Normalize-* + +core.* +*.[co] +*.so +*.bs +*.out +*.def +*.exp + +cover_db +*.gcda +*.gcov +*.gcno + +Debian_CPANTS.txt diff --git a/Changes b/Changes new file mode 100644 index 0000000..28f7f1c --- /dev/null +++ b/Changes @@ -0,0 +1,5 @@ +Revision history for Hash-Normalize + +0.01 2017-05-26 15:00 UTC + First version, released on an unsuspecting world. + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..e0d8689 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,13 @@ +Changes +MANIFEST +META.json +META.yml +Makefile.PL +README +lib/Hash/Normalize.pm +t/00-load.t +t/01-import.t +t/10-empty.t +t/11-base.t +t/12-renormalize.t +t/20-stash.t diff --git a/META.json b/META.json new file mode 100644 index 0000000..2aa6a9e --- /dev/null +++ b/META.json @@ -0,0 +1,66 @@ +{ + "abstract" : "Automatically normalize Unicode hash keys.", + "author" : [ + "Vincent Pit " + ], + "dynamic_config" : 0, + "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : 2 + }, + "name" : "Hash-Normalize", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "Carp" : "0", + "Exporter" : "0", + "ExtUtils::MakeMaker" : "0", + "Test::More" : "0", + "Unicode::Normalize" : "0", + "Variable::Magic" : "0.51", + "base" : "0", + "lib" : "0" + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "runtime" : { + "requires" : { + "Carp" : "0", + "Exporter" : "0", + "Unicode::Normalize" : "0", + "Variable::Magic" : "0.51", + "base" : "0", + "perl" : "5.010" + } + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "web" : "http://rt.cpan.org/Dist/Display.html?Name=Hash-Normalize" + }, + "homepage" : "http://search.cpan.org/dist/Hash-Normalize/", + "license" : [ + "http://dev.perl.org/licenses/" + ], + "repository" : { + "url" : "http://git.profvince.com/?p=perl%2Fmodules%2FHash-Normalize.git" + } + }, + "version" : "0.01", + "x_serialization_backend" : "JSON::PP version 2.93" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..598e9ef --- /dev/null +++ b/META.yml @@ -0,0 +1,40 @@ +--- +abstract: 'Automatically normalize Unicode hash keys.' +author: + - 'Vincent Pit ' +build_requires: + Carp: '0' + Exporter: '0' + ExtUtils::MakeMaker: '0' + Test::More: '0' + Unicode::Normalize: '0' + Variable::Magic: '0.51' + base: '0' + lib: '0' +configure_requires: + ExtUtils::MakeMaker: '0' +dynamic_config: 0 +generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Hash-Normalize +no_index: + directory: + - t + - inc +requires: + Carp: '0' + Exporter: '0' + Unicode::Normalize: '0' + Variable::Magic: '0.51' + base: '0' + perl: '5.010' +resources: + bugtracker: http://rt.cpan.org/Dist/Display.html?Name=Hash-Normalize + homepage: http://search.cpan.org/dist/Hash-Normalize/ + license: http://dev.perl.org/licenses/ + repository: http://git.profvince.com/?p=perl%2Fmodules%2FHash-Normalize.git +version: '0.01' +x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..ecdb499 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,63 @@ +use 5.010; + +use strict; +use warnings; +use ExtUtils::MakeMaker; + +my $dist = 'Hash-Normalize'; + +(my $name = $dist) =~ s{-}{::}g; + +(my $file = $dist) =~ s{-}{/}g; +$file = "lib/$file.pm"; + +my %PREREQ_PM = ( + 'Carp' => 0, + 'Exporter' => 0, + 'Unicode::Normalize' => 0, + 'Variable::Magic' => '0.51', + 'base' => 0, +); + +my %BUILD_REQUIRES = ( + 'ExtUtils::MakeMaker' => 0, + 'Test::More' => 0, + 'lib' => 0, + %PREREQ_PM, +); + +my %META = ( + configure_requires => { + 'ExtUtils::MakeMaker' => 0, + }, + build_requires => { + %BUILD_REQUIRES, + }, + dynamic_config => 0, + resources => { + bugtracker => "http://rt.cpan.org/Dist/Display.html?Name=$dist", + homepage => "http://search.cpan.org/dist/$dist/", + license => 'http://dev.perl.org/licenses/', + repository => "http://git.profvince.com/?p=perl%2Fmodules%2F$dist.git", + }, +); + +WriteMakefile( + NAME => $name, + AUTHOR => 'Vincent Pit ', + LICENSE => 'perl', + VERSION_FROM => $file, + ABSTRACT_FROM => $file, + PL_FILES => {}, + BUILD_REQUIRES => \%BUILD_REQUIRES, + PREREQ_PM => \%PREREQ_PM, + MIN_PERL_VERSION => '5.010', + META_MERGE => \%META, + dist => { + PREOP => "pod2text -u $file > \$(DISTVNAME)/README", + COMPRESS => 'gzip -9f', SUFFIX => 'gz' + }, + clean => { + FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt" + }, +); diff --git a/README b/README new file mode 100644 index 0000000..c062174 --- /dev/null +++ b/README @@ -0,0 +1,126 @@ +NAME + Hash::Normalize - Automatically normalize Unicode hash keys. + +VERSION + Version 0.01 + +SYNOPSIS + use Hash::Normalize qw; + + normalize my %hash, 'NFC'; + + $hash{café} = 'coffee'; # NFD, "cafe\x{301}" + + print $hash{café}; # NFD, "cafe\x{301}" + # 'coffee' is printed + + print $hash{café}; # NFC, "caf\x{e9}" + # 'coffee' is also printed + +DESCRIPTION + This module provides an utility routine that augments a given Perl hash + table so that its keys are automatically normalized following one of the + Unicode normalization schemes. All the following actions on this hash + will be made regardless of how the key used for the action is + normalized. + + Since this module does not use the "tie" mechanism, normalized hashes + are indistinguishable from regular hashes as far as Perl is concerned, + but this module also provides "get_normalization" to identify them if + necessary. + +FUNCTIONS + "normalize" + normalize %hash; + normalize %hash, $mode; + + Applies the Unicode normalization scheme $mode onto %hash. $mode + defaults to 'NFC' if omitted, and should match + "/^(?:(?:nf)?k?|fc)[cd]$/i" otherwise. + + "normalize" will first try to forcefully normalize the existing keys in + %hash to the new mode, but it will throw an exception if there are + distinct keys that have the same normalization. All the keys + subsequently used for fetches, stores, exists, deletes and list + assignments are then first passed through the according normalization + procedure. "keys %hash" will also return the list of normalized keys. + + "get_normalization" + my $mode = get_normalization %hash; + normalize %hash, $mode; + + Returns the current Unicode normalization scheme in use for %hash, or + "undef" if it is a plain hash. + +NORMALIZED SYMBOL LOOKUPS + Stashes (Perl symbol tables) are implemented as plain hashes, therefore + one can use "normalize %Pkg::" on them to make sure that Unicode symbol + lookups are made regardless of normalization. + + package Foo; + + BEGIN { + require Hash::Normalize; + # Enforce NFC normalization + Hash::Normalize::normalize(%Foo::, 'NFC') + } + + sub café { # NFD, "cafe\x{301}" + return 'coffee' + } + + sub coffee_nfc { + café() # NFC, "cafe\x{e9}" + } + + sub coffee_nfd { + café() # NFD, "cafe\x{301}" + } + + # Both coffee_nfc() and coffee_nfd() return 'coffee' + +CAVEATS + Using a normalized hash is slightly slower than a plain hash, due to the + normalization procedure and the overhead of magic. + + If a hash is initialized from a normalized hash by list assignment + ("%new = %normalized"), then the normalization scheme will not be + carried over to the new hash, although its keys will initially be + normalized like the ones from the original hash. + +EXPORT + The functions "normalize" and "get_normalization" are only exported on + request by specifying their names in the module import list. + +DEPENDENCIES + perl 5.10. + + Carp, Exporter (core since perl 5). + + Unicode::Normalize (core since perl 5.8). + + Variable::Magic 0.51. + +AUTHOR + Vincent Pit, "", . + + You can contact me by mail or on "irc.perl.org" (vincent). + +BUGS + Please report any bugs or feature requests to "bug-hash-normalize at + rt.cpan.org", or through the web interface at + . I will + be notified, and then you'll automatically be notified of progress on + your bug as I make changes. + +SUPPORT + You can find documentation for this module with the perldoc command. + + perldoc Hash::Normalize + +COPYRIGHT & LICENSE + Copyright 2017 Vincent Pit, all rights reserved. + + This program is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. + diff --git a/lib/Hash/Normalize.pm b/lib/Hash/Normalize.pm new file mode 100644 index 0000000..194f2c1 --- /dev/null +++ b/lib/Hash/Normalize.pm @@ -0,0 +1,211 @@ +package Hash::Normalize; + +use 5.010; + +use strict; +use warnings; + +=encoding UTF-8 + +=head1 NAME + +Hash::Normalize - Automatically normalize Unicode hash keys. + +=head1 VERSION + +Version 0.01 + +=cut + +our $VERSION; +BEGIN { + $VERSION = '0.01'; +} + +=head1 SYNOPSIS + + use Hash::Normalize qw; + + normalize my %hash, 'NFC'; + + $hash{café} = 'coffee'; # NFD, "cafe\x{301}" + + print $hash{café}; # NFD, "cafe\x{301}" + # 'coffee' is printed + + print $hash{café}; # NFC, "caf\x{e9}" + # 'coffee' is also printed + +=head1 DESCRIPTION + +This module provides an utility routine that augments a given Perl hash table so that its keys are automatically normalized following one of the Unicode normalization schemes. +All the following actions on this hash will be made regardless of how the key used for the action is normalized. + +Since this module does not use the C mechanism, normalized hashes are indistinguishable from regular hashes as far as Perl is concerned, but this module also provides L to identify them if necessary. + +=cut + +use Variable::Magic; +use Unicode::Normalize (); + +=head1 FUNCTIONS + +=head2 C + + normalize %hash; + normalize %hash, $mode; + +Applies the Unicode normalization scheme C<$mode> onto C<%hash>. +C<$mode> defaults to C<'NFC'> if omitted, and should match C otherwise. + +C will first try to forcefully normalize the existing keys in C<%hash> to the new mode, but it will throw an exception if there are distinct keys that have the same normalization. +All the keys subsequently used for fetches, stores, exists, deletes and list assignments are then first passed through the according normalization procedure. +C will also return the list of normalized keys. + +=cut + +sub _remap { $_[2] = Unicode::Normalize::normalize($_[1], "$_[2]"); undef } + +my $wiz = Variable::Magic::wizard( + data => sub { $_[1] }, + fetch => \&_remap, + store => \&_remap, + exists => \&_remap, + delete => \&_remap, + copy_key => 1, +); + +sub _validate_mode { + my $mode = shift; + + $mode = 'nfc' unless defined $mode; + if ($mode =~ /^(?:nf)?(k?[cd])$/i) { + $mode = uc "NF$1"; + } elsif ($mode =~ /^(fc[cd])$/i) { + $mode = uc "$1"; + } else { + require Carp; + Carp::croak('Invalid normalization'); + } + + return $mode +} + +sub normalize (\%;$) { + my ($hash, $mode) = @_; + + my $previous_mode = &get_normalization($hash); + my $new_mode = _validate_mode($mode); + return $hash if defined $previous_mode and $previous_mode eq $new_mode; + + &Variable::Magic::dispell($hash, $wiz); + + if (%$hash) { + my %dup; + for my $key (keys %$hash) { + my $norm = Unicode::Normalize::normalize($new_mode, $key); + if (exists $dup{$norm}) { + require Carp; + Carp::croak('Key collision after normalization'); + } + $dup{$norm} = $hash->{$key}; + } + %$hash = %dup; + } + + &Variable::Magic::cast($hash, $wiz, $new_mode); + + return $hash; +} + +=head2 C + + my $mode = get_normalization %hash; + normalize %hash, $mode; + +Returns the current Unicode normalization scheme in use for C<%hash>, or C if it is a plain hash. + +=cut + +sub get_normalization (\%) { &Variable::Magic::getdata($_[0], $wiz) } + +=head1 NORMALIZED SYMBOL LOOKUPS + +Stashes (Perl symbol tables) are implemented as plain hashes, therefore one can use C on them to make sure that Unicode symbol lookups are made regardless of normalization. + + package Foo; + + BEGIN { + require Hash::Normalize; + # Enforce NFC normalization + Hash::Normalize::normalize(%Foo::, 'NFC') + } + + sub café { # NFD, "cafe\x{301}" + return 'coffee' + } + + sub coffee_nfc { + café() # NFC, "cafe\x{e9}" + } + + sub coffee_nfd { + café() # NFD, "cafe\x{301}" + } + + # Both coffee_nfc() and coffee_nfd() return 'coffee' + +=head1 CAVEATS + +Using a normalized hash is slightly slower than a plain hash, due to the normalization procedure and the overhead of magic. + +If a hash is initialized from a normalized hash by list assignment (C<%new = %normalized>), then the normalization scheme will not be carried over to the new hash, although its keys will initially be normalized like the ones from the original hash. + +=head1 EXPORT + +The functions L and L are only exported on request by specifying their names in the module import list. + +=cut + +use base 'Exporter'; + +our @EXPORT = (); +our %EXPORT_TAGS = (); +our @EXPORT_OK = qw; + +=head1 DEPENDENCIES + +L 5.10. + +L, L (core since perl 5). + +L (core since perl 5.8). + +L 0.51. + +=head1 AUTHOR + +Vincent Pit, C<< >>, L. + +You can contact me by mail or on C (vincent). + +=head1 BUGS + +Please report any bugs or feature requests to C, or through the web interface at L. +I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc Hash::Normalize + +=head1 COPYRIGHT & LICENSE + +Copyright 2017 Vincent Pit, all rights reserved. + +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. + +=cut + +1; # End of Hash::Normalize diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..8d0d0e4 --- /dev/null +++ b/t/00-load.t @@ -0,0 +1,12 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 1; + +BEGIN { + use_ok('Hash::Normalize'); +} + +diag("Testing Hash::Normalize $Hash::Normalize::VERSION, Perl $], $^X"); diff --git a/t/01-import.t b/t/01-import.t new file mode 100644 index 0000000..acca0aa --- /dev/null +++ b/t/01-import.t @@ -0,0 +1,19 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 2 * 2; + +require Hash::Normalize; + +my %syms = ( + normalize => '\%;$', + get_normalization => '\%', +); + +for (sort keys %syms) { + eval { Hash::Normalize->import($_) }; + is $@, '', "import $_"; + is prototype($_), $syms{$_}, "prototype $_"; +} diff --git a/t/10-empty.t b/t/10-empty.t new file mode 100644 index 0000000..a3cce37 --- /dev/null +++ b/t/10-empty.t @@ -0,0 +1,35 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 9; + +use Hash::Normalize qw; + +my %h; +is get_normalization(%h), undef, 'brand new hash is not normalized'; + +normalize %h; +is get_normalization(%h), 'NFC', 'composed normalization by default'; + +normalize %h, 'nfd'; +is get_normalization(%h), 'NFD', 'switch normalization to NFD'; + +normalize %h, 'd'; +is get_normalization(%h), 'NFD', 'reapply the same normalization'; + +normalize %h, 'kc'; +is get_normalization(%h), 'NFKC', 'switch normalization to NFKC'; + +normalize %h, 'NFkd'; +is get_normalization(%h), 'NFKD', 'switch normalization to NFKD'; + +normalize %h, 'fCc'; +is get_normalization(%h), 'FCC', 'switch normalization to FCC'; + +normalize %h, 'FcD'; +is get_normalization(%h), 'FCD', 'switch normalization to FCD'; + +eval { normalize %h, 'XYZ' }; +like $@, qr/^Invalid normalization /, 'invalid normalization croaks'; diff --git a/t/11-base.t b/t/11-base.t new file mode 100644 index 0000000..ddee669 --- /dev/null +++ b/t/11-base.t @@ -0,0 +1,64 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => (1 + 2 * 3) * 3 + 4; + +use Hash::Normalize qw; + +my $cafe_nfc = "caf\x{e9}"; +my $cafe_nfd = "cafe\x{301}"; + +my %h1 = (cafe => 1); +normalize %h1; +is_deeply [ sort keys %h1 ], [ 'cafe' ], 'new hash'; + +for my $run (1, 2) { + my $r1 = $h1{'cafe'}; + my $r2 = $h1{$cafe_nfc}; + my $r3 = $h1{$cafe_nfd}; + + is $r1, 1, "init run $run fetch 1"; + is $r2, undef, "init run $run fetch 2"; + is $r3, undef, "init run $run fetch 3"; +} + +$h1{$cafe_nfd} = 2; + +is_deeply [ sort keys %h1 ], [ 'cafe', $cafe_nfc ], 'after store 1'; + +for my $run (1, 2) { + my $r1 = $h1{'cafe'}; + my $r2 = $h1{$cafe_nfc}; + my $r3 = $h1{$cafe_nfd}; + + is $r1, 1, "store 1 run $run fetch 1"; + is $r2, 2, "store 1 run $run fetch 2"; + is $r3, 2, "store 1 run $run fetch 3"; +} + +$h1{$cafe_nfc} = 3; + +is_deeply [ sort keys %h1 ], [ 'cafe', $cafe_nfc ], 'after store 2'; + +for my $run (1, 2) { + my $r1 = $h1{'cafe'}; + my $r2 = $h1{$cafe_nfc}; + my $r3 = $h1{$cafe_nfd}; + + is $r1, 1, "store 2 run $run fetch 1"; + is $r2, 3, "store 2 run $run fetch 2"; + is $r3, 3, "store 2 run $run fetch 3"; +} + +my %h2; +normalize %h2, 'd'; +%h2 = %h1; +is_deeply [ sort keys %h2 ], [ 'cafe', $cafe_nfd ], 'list assign'; + +is exists $h1{$cafe_nfd}, 1, 'exists'; + +my $val = delete $h1{$cafe_nfd}; +is $val, 3, 'delete'; +is_deeply [ sort keys %h1 ], [ 'cafe' ], 'after delete'; diff --git a/t/12-renormalize.t b/t/12-renormalize.t new file mode 100644 index 0000000..f1bd246 --- /dev/null +++ b/t/12-renormalize.t @@ -0,0 +1,30 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 6; + +use Hash::Normalize qw; + +my $cafe_nfc = "caf\x{e9}"; +my $cafe_nfd = "cafe\x{301}"; + +my %h1 = (cafe => 1, $cafe_nfc => 2); +normalize %h1; +is_deeply [ sort keys %h1 ], [ 'cafe', $cafe_nfc ], 'new hash'; + +my %h2 = %h1; +normalize %h2; +is_deeply [ sort keys %h2 ], [ 'cafe', $cafe_nfc ], 'idempotent renormalization'; + +my %h3 = %h1; +normalize %h3, 'D'; +is_deeply [ sort keys %h3 ], [ 'cafe', $cafe_nfd ], 'true renormalization'; + +my %h4 = (cafe => 1, $cafe_nfc => 2, $cafe_nfd => 3); +my $keys = join ' ', sort keys %h4; +is scalar(keys %h4), 3, 'plain hash contains 3 keys'; +eval { normalize %h4 }; +like $@, qr/^Key collision after normalization /, 'normalizations collide'; +is join(' ', sort keys %h4), $keys, 'collision happened but hash was untouched' diff --git a/t/20-stash.t b/t/20-stash.t new file mode 100644 index 0000000..6ca39d4 --- /dev/null +++ b/t/20-stash.t @@ -0,0 +1,44 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 5; + +use Hash::Normalize qw; + +my $cafe_nfc = "caf\x{e9}"; +my $cafe_nfd = "cafe\x{301}"; + +eval <<"CODE"; +package Hash::Normalize::TestPkg; + +BEGIN { Hash::Normalize::normalize(%Hash::Normalize::TestPkg::) } + +sub $cafe_nfd { return 123 } + +sub get_coffee_nfc { $cafe_nfc() + 1 } + +sub get_coffee_nfd { $cafe_nfd() + 2 } + +package Hash::Normalize::TestPkg2; + +our \@ISA; +BEGIN { + \@ISA = 'Hash::Normalize::TestPkg'; +} + +1; +CODE + +is $@, '', 'test package compiled properly'; + +SKIP: { + skip 'eval suffers from The Unicode Bug before perl 5.16' => 4 + unless "$]" >= 5.016; + + is Hash::Normalize::TestPkg::get_coffee_nfc(), 124, 'nfc func call'; + is Hash::Normalize::TestPkg::get_coffee_nfd(), 125, 'nfd func call'; + is Hash::Normalize::TestPkg2->get_coffee_nfc(), 124, 'nfc meth call'; + is Hash::Normalize::TestPkg2->get_coffee_nfd(), 125, 'nfd meth call'; +} diff --git a/t/91-pod.t b/t/91-pod.t new file mode 100644 index 0000000..539df9f --- /dev/null +++ b/t/91-pod.t @@ -0,0 +1,13 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +use lib 't/lib'; +use VPIT::TestHelpers; + +load_or_skip_all('Test::Pod', '1.22', [ ]); + +all_pod_files_ok(); diff --git a/t/92-pod-coverage.t b/t/92-pod-coverage.t new file mode 100644 index 0000000..d1434bb --- /dev/null +++ b/t/92-pod-coverage.t @@ -0,0 +1,14 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +use lib 't/lib'; +use VPIT::TestHelpers; + +load_or_skip_all('Test::Pod::Coverage', '1.08', [ ]); +load_or_skip_all('Pod::Coverage', '0.18' ); + +all_pod_coverage_ok(); diff --git a/t/93-pod-spelling.t b/t/93-pod-spelling.t new file mode 100644 index 0000000..8173209 --- /dev/null +++ b/t/93-pod-spelling.t @@ -0,0 +1,13 @@ +#!perl + +use strict; +use warnings; + +use Test::More; + +use lib 't/lib'; +use VPIT::TestHelpers; + +load_or_skip_all('Test::Pod::Spelling::CommonMistakes', '1.0', [ ]); + +all_pod_files_ok(); diff --git a/t/95-portability-files.t b/t/95-portability-files.t new file mode 100644 index 0000000..7119271 --- /dev/null +++ b/t/95-portability-files.t @@ -0,0 +1,13 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +use lib 't/lib'; +use VPIT::TestHelpers; + +load_or_skip_all('Test::Portability::Files', undef, [ ]); + +run_tests(); diff --git a/t/lib/VPIT/TestHelpers.pm b/t/lib/VPIT/TestHelpers.pm new file mode 100644 index 0000000..10550ee --- /dev/null +++ b/t/lib/VPIT/TestHelpers.pm @@ -0,0 +1,848 @@ +package VPIT::TestHelpers; + +use strict; +use warnings; + +use Config (); + +=head1 NAME + +VPIT::TestHelpers + +=head1 SYNTAX + + use VPIT::TestHelpers ( + feature1 => \@feature1_args, + feature2 => \@feature2_args, + ); + +=cut + +sub export_to_pkg { + my ($subs, $pkg) = @_; + + while (my ($name, $code) = each %$subs) { + no strict 'refs'; + *{$pkg.'::'.$name} = $code; + } + + return 1; +} + +sub sanitize_prefix { + my $prefix = shift; + + if (defined $prefix) { + if (length $prefix and $prefix !~ /_$/) { + $prefix .= '_'; + } + } else { + $prefix = ''; + } + + return $prefix; +} + +my %default_exports = ( + load_or_skip => \&load_or_skip, + load_or_skip_all => \&load_or_skip_all, + skip_all => \&skip_all, +); + +my %features = ( + threads => \&init_threads, + usleep => \&init_usleep, + run_perl => \&init_run_perl, + capture => \&init_capture, +); + +sub import { + shift; + my @opts = @_; + + my %exports = %default_exports; + + for (my $i = 0; $i <= $#opts; ++$i) { + my $feature = $opts[$i]; + next unless defined $feature; + + my $args; + if ($i < $#opts and defined $opts[$i+1] and ref $opts[$i+1] eq 'ARRAY') { + ++$i; + $args = $opts[$i]; + } else { + $args = [ ]; + } + + my $handler = $features{$feature}; + die "Unknown feature '$feature'" unless defined $handler; + + my %syms = $handler->(@$args); + + $exports{$_} = $syms{$_} for sort keys %syms; + } + + export_to_pkg \%exports => scalar caller; +} + +my $test_sub = sub { + my $sub = shift; + + my $stash; + if ($INC{'Test/Leaner.pm'}) { + $stash = \%Test::Leaner::; + } else { + require Test::More; + $stash = \%Test::More::; + } + + my $glob = $stash->{$sub}; + return $glob ? *$glob{CODE} : undef; +}; + +sub skip { $test_sub->('skip')->(@_) } + +sub skip_all { $test_sub->('plan')->(skip_all => $_[0]) } + +sub diag { + my $diag = $test_sub->('diag'); + $diag->($_) for @_; +} + +our $TODO; +local $TODO; + +sub load { + my ($pkg, $ver, $imports) = @_; + + my $spec = $ver && $ver !~ /^[0._]*$/ ? "$pkg $ver" : $pkg; + my $err; + + local $@; + if (eval "use $spec (); 1") { + $ver = do { no strict 'refs'; ${"${pkg}::VERSION"} }; + $ver = 'undef' unless defined $ver; + + if ($imports) { + my @imports = @$imports; + my $caller = (caller 1)[0]; + local $@; + my $res = eval <<"IMPORTER"; +package + $caller; +BEGIN { \$pkg->import(\@imports) } +1; +IMPORTER + $err = "Could not import '@imports' from $pkg $ver: $@" unless $res; + } + } else { + (my $file = "$pkg.pm") =~ s{::}{/}g; + delete $INC{$file}; + $err = "Could not load $spec"; + } + + if ($err) { + return wantarray ? (0, $err) : 0; + } else { + diag "Using $pkg $ver"; + return 1; + } +} + +sub load_or_skip { + my ($pkg, $ver, $imports, $tests) = @_; + + die 'You must specify how many tests to skip' unless defined $tests; + + my ($loaded, $err) = load($pkg, $ver, $imports); + skip $err => $tests unless $loaded; + + return $loaded; +} + +sub load_or_skip_all { + my ($pkg, $ver, $imports) = @_; + + my ($loaded, $err) = load($pkg, $ver, $imports); + skip_all $err unless $loaded; + + return $loaded; +} + +=head1 FEATURES + +=head2 C + +=over 4 + +=item * + +Import : + + use VPIT::TestHelpers run_perl => [ $p ] + +where : + +=over 8 + +=item - + +C<$p> is prefixed to the constants exported by this feature (defaults to C<''>). + +=back + +=item * + +Dependencies : + +=over 8 + +=item - + +L + +=back + +=item * + +Exports : + +=over 8 + +=item - + +C + +=item - + +C + +=item - + +C (possibly prefixed by C<$p>) + +=back + +=back + +=cut + +sub fresh_perl_env (&) { + my $handler = shift; + + my ($SystemRoot, $PATH) = @ENV{qw}; + my $ld_name = $Config::Config{ldlibpthname}; + my $ldlibpth = $ENV{$ld_name}; + + local %ENV; + $ENV{$ld_name} = $ldlibpth if defined $ldlibpth; + $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot; + $ENV{PATH} = $PATH if $^O eq 'cygwin' and defined $PATH; + + my $perl = $^X; + unless (-e $perl and -x $perl) { + $perl = $Config::Config{perlpath}; + unless (-e $perl and -x $perl) { + return undef; + } + } + + return $handler->($perl, '-T', map("-I$_", @INC)); +} + +sub init_run_perl { + my $p = sanitize_prefix(shift); + + # This is only required for run_perl_file(), so it is not needed for the + # threads feature which only calls run_perl() - don't forget to update its + # requirements if this ever changes. + require File::Spec; + + return ( + run_perl => \&run_perl, + run_perl_file => \&run_perl_file, + "${p}RUN_PERL_FAILED" => sub () { 'Could not execute perl subprocess' }, + ); +} + +sub run_perl { + my $code = shift; + + if ($code =~ /"/) { + die 'Double quotes in evaluated code are not portable'; + } + + fresh_perl_env { + my ($perl, @perl_args) = @_; + system { $perl } $perl, @perl_args, '-e', $code; + }; +} + +sub run_perl_file { + my $file = shift; + + $file = File::Spec->rel2abs($file); + unless (-e $file and -r _) { + die 'Could not run perl file'; + } + + fresh_perl_env { + my ($perl, @perl_args) = @_; + system { $perl } $perl, @perl_args, $file; + }; +} + +=head2 C + +=over 4 + +=item * + +Import : + + use VPIT::TestHelpers capture => [ $p ]; + +where : + +=over 8 + +=item - + +C<$p> is prefixed to the constants exported by this feature (defaults to C<''>). + +=back + +=item * + +Dependencies : + +=over 8 + +=item - + +Neither VMS nor OS/2 + +=item - + +L + +=item - + +L + +=item - + +L + +=item - + +On MSWin32 : L + +=back + +=item * + +Exports : + +=over 8 + +=item - + +C + +=item - + +C (possibly prefixed by C<$p>) + +=item - + +C + +=item - + +C (possibly prefixed by C<$p>) + +=back + +=back + +=cut + +sub init_capture { + my $p = sanitize_prefix(shift); + + skip_all 'Cannot capture output on VMS' if $^O eq 'VMS'; + skip_all 'Cannot capture output on OS/2' if $^O eq 'os2'; + + load_or_skip_all 'IO::Handle', '0', [ ]; + load_or_skip_all 'IO::Select', '0', [ ]; + load_or_skip_all 'IPC::Open3', '0', [ ]; + if ($^O eq 'MSWin32') { + load_or_skip_all 'Socket', '0', [ ]; + } + + return ( + capture => \&capture, + "${p}CAPTURE_FAILED" => \&capture_failed_msg, + capture_perl => \&capture_perl, + "${p}CAPTURE_PERL_FAILED" => \&capture_perl_failed_msg, + ); +} + +# Inspired from IPC::Cmd + +sub capture { + my @cmd = @_; + + my $want = wantarray; + + my $fail = sub { + my $err = $!; + my $ext_err = $^O eq 'MSWin32' ? $^E : undef; + + my $syscall = shift; + my $args = join ', ', @_; + + my $msg = "$syscall($args) failed: "; + + if (defined $err) { + no warnings 'numeric'; + my ($err_code, $err_str) = (int $err, "$err"); + $msg .= "$err_str ($err_code)"; + } + + if (defined $ext_err) { + no warnings 'numeric'; + my ($ext_err_code, $ext_err_str) = (int $ext_err, "$ext_err"); + $msg .= ", $ext_err_str ($ext_err_code)"; + } + + die "$msg\n"; + }; + + my ($status, $content_out, $content_err); + + local $@; + my $ok = eval { + my ($pid, $out, $err); + + if ($^O eq 'MSWin32') { + my $pipe = sub { + socketpair $_[0], $_[1], + &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC + or $fail->(qw); + shutdown $_[0], 1 or $fail->(qw); + shutdown $_[1], 0 or $fail->(qw); + return 1; + }; + local (*IN_R, *IN_W); + local (*OUT_R, *OUT_W); + local (*ERR_R, *ERR_W); + $pipe->(*IN_R, *IN_W); + $pipe->(*OUT_R, *OUT_W); + $pipe->(*ERR_R, *ERR_W); + + $pid = IPC::Open3::open3('>&IN_R', '<&OUT_W', '<&ERR_W', @cmd); + + close *IN_W or $fail->(qw); + $out = *OUT_R; + $err = *ERR_R; + } else { + my $in = IO::Handle->new; + $out = IO::Handle->new; + $out->autoflush(1); + $err = IO::Handle->new; + $err->autoflush(1); + + $pid = IPC::Open3::open3($in, $out, $err, @cmd); + + close $in; + } + + # Forward signals to the child (except SIGKILL) + my %sig_handlers; + foreach my $s (keys %SIG) { + $sig_handlers{$s} = sub { + kill "$s" => $pid; + $SIG{$s} = $sig_handlers{$s}; + }; + } + local $SIG{$_} = $sig_handlers{$_} for keys %SIG; + + unless ($want) { + close $out or $fail->(qw); + close $err or $fail->(qw); + waitpid $pid, 0; + $status = $?; + return 1; + } + + my $sel = IO::Select->new(); + $sel->add($out, $err); + + my $fd_out = fileno $out; + my $fd_err = fileno $err; + + my %contents; + $contents{$fd_out} = ''; + $contents{$fd_err} = ''; + + while (my @ready = $sel->can_read) { + for my $fh (@ready) { + my $buf; + my $bytes_read = sysread $fh, $buf, 4096; + if (not defined $bytes_read) { + $fail->('sysread', 'fd(' . fileno($fh) . ')'); + } elsif ($bytes_read) { + $contents{fileno($fh)} .= $buf; + } else { + $sel->remove($fh); + close $fh or $fail->('close', 'fd(' . fileno($fh) . ')'); + last unless $sel->count; + } + } + } + + waitpid $pid, 0; + $status = $?; + + if ($^O eq 'MSWin32') { + # Manual CRLF translation that couldn't be done with sysread. + s/\x0D\x0A/\n/g for values %contents; + } + + $content_out = $contents{$fd_out}; + $content_err = $contents{$fd_err}; + + 1; + }; + + if ("$]" < 5.014 and $ok and ($status >> 8) == 255 and defined $content_err + and $content_err =~ /^open3/) { + # Before perl commit 8960aa87 (between 5.12 and 5.14), exceptions in open3 + # could be reported to STDERR instead of being propagated, so work around + # this. + $ok = 0; + $@ = $content_err; + } + + if ($ok) { + return ($status, $content_out, $content_err); + } else { + my $err = $@; + chomp $err; + return (undef, $err); + } +} + +sub capture_failed_msg { + my $details = shift; + + my $msg = 'Could not capture command output'; + $msg .= " ($details)" if defined $details; + + return $msg; +} + +sub capture_perl { + my $code = shift; + + if ($code =~ /"/) { + die 'Double quotes in evaluated code are not portable'; + } + + fresh_perl_env { + my @perl = @_; + capture @perl, '-e', $code; + }; +} + +sub capture_perl_failed_msg { + my $details = shift; + + my $msg = 'Could not capture perl output'; + $msg .= " ($details)" if defined $details; + + return $msg; +} + +=head2 C + +=over 4 + +=item * + +Import : + + use VPIT::TestHelpers threads => [ + $pkg, $threadsafe_var, $force_var + ]; + +where : + +=over 8 + +=item - + +C<$pkg> is the target package name that will be exercised by this test ; + +=item - + +C<$threadsafe_var> is the name of an optional variable in C<$pkg> that evaluates to true if and only if the module claims to be thread safe (not checked if either C<$threadsafe_var> or C<$pkg> is C) ; + +=item - + +C<$force_var> is the name of the environment variable that can be used to force the thread tests (defaults to C). + +=back + +=item * + +Dependencies : + +=over 8 + +=item - + +C 5.13.4 + +=item - + +L + +=item - + +L 1.67 + +=item - + +L 1.14 + +=back + +=item * + +Exports : + +=over 8 + +=item - + +C + +=back + +=item * + +Notes : + +=over 8 + +=item - + +C<< exit => 'threads_only' >> is passed to C<< threads->import >>. + +=back + +=back + +=cut + +sub init_threads { + my ($pkg, $threadsafe_var, $force_var) = @_; + + skip_all 'This perl wasn\'t built to support threads' + unless $Config::Config{useithreads}; + + if (defined $pkg and defined $threadsafe_var) { + my $threadsafe; + # run_perl() doesn't actually require anything + my $stat = run_perl("require POSIX; require $pkg; exit($threadsafe_var ? POSIX::EXIT_SUCCESS() : POSIX::EXIT_FAILURE())"); + if (defined $stat) { + require POSIX; + my $res = $stat >> 8; + if ($res == POSIX::EXIT_SUCCESS()) { + $threadsafe = 1; + } elsif ($res == POSIX::EXIT_FAILURE()) { + $threadsafe = !1; + } + } + if (not defined $threadsafe) { + skip_all "Could not detect if $pkg is thread safe or not"; + } elsif (not $threadsafe) { + skip_all "This $pkg is not thread safe"; + } + } + + $force_var = 'PERL_FORCE_TEST_THREADS' unless defined $force_var; + my $force = $ENV{$force_var} ? 1 : !1; + skip_all 'perl 5.13.4 required to test thread safety' + unless $force or "$]" >= 5.013_004; + + unless ($INC{'threads.pm'}) { + my $test_module; + if ($INC{'Test/Leaner.pm'}) { + $test_module = 'Test::Leaner'; + } elsif ($INC{'Test/More.pm'}) { + $test_module = 'Test::More'; + } + die "$test_module was loaded too soon" if defined $test_module; + } + + load_or_skip_all 'threads', $force ? '0' : '1.67', [ + exit => 'threads_only', + ]; + load_or_skip_all 'threads::shared', $force ? '0' : '1.14', [ ]; + + diag "Threads testing forced by \$ENV{$force_var}" if $force; + + return spawn => \&spawn; +} + +sub spawn { + local $@; + my @diag; + my $thread = eval { + local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" }; + threads->create(@_); + }; + push @diag, "Thread creation error: $@" if $@; + diag @diag; + return $thread ? $thread : (); +} + +=head2 C + +=over 4 + +=item * + +Import : + + use VPIT::TestHelpers 'usleep' => [ @impls ]; + +where : + +=over 8 + +=item - + +C<@impls> is the list of desired implementations (which may be C<'Time::HiRes'>, C<'select'> or C<'sleep'>), in the order they should be checked. +When the list is empty, it defaults to all of them. + +=back + +=item * + +Dependencies : none + +=item * + +Exports : + +=over 8 + +=item - + +C + +=back + +=back + +=cut + +sub init_usleep { + my (@impls) = @_; + + my %impls = ( + 'Time::HiRes' => sub { + if (do { local $@; eval { require Time::HiRes; 1 } }) { + defined and diag "Using usleep() from Time::HiRes $_" + for $Time::HiRes::VERSION; + return \&Time::HiRes::usleep; + } else { + return undef; + } + }, + 'select' => sub { + if ($Config::Config{d_select}) { + diag 'Using select()-based fallback usleep()'; + return sub ($) { + my $s = $_[0]; + my $r = 0; + while ($s > 0) { + my ($found, $t) = select(undef, undef, undef, $s / 1e6); + last unless defined $t; + $t = int($t * 1e6); + $s -= $t; + $r += $t; + } + return $r; + }; + } else { + return undef; + } + }, + 'sleep' => sub { + diag 'Using sleep()-based fallback usleep()'; + return sub ($) { + my $ms = int $_[0]; + my $s = int($ms / 1e6) + ($ms % 1e6 == 0 ? 0 : 1); + my $t = sleep $s; + return $t * 1e6; + }; + }, + ); + + @impls = qw unless @impls; + + my $usleep; + for my $impl (@impls) { + next unless defined $impl and $impls{$impl}; + $usleep = $impls{$impl}->(); + last if defined $usleep; + } + + skip_all "Could not find a suitable usleep() implementation among: @impls" + unless $usleep; + + return usleep => $usleep; +} + +=head1 CLASSES + +=head2 C + +Syntax : + + { + my $guard = VPIT::TestHelpers::Guard->new($coderef); + ... + } # $codref called here + +=cut + +package VPIT::TestHelpers::Guard; + +sub new { + my ($class, $code) = @_; + + bless { code => $code }, $class; +} + +sub DESTROY { $_[0]->{code}->() } + +=head1 AUTHOR + +Vincent Pit, C<< >>, L. + +=head1 COPYRIGHT & LICENSE + +Copyright 2012,2013,2014,2015 Vincent Pit, all rights reserved. + +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. + +=cut + +1;