Tie-Hash-Regex-2.0.0/0000755000175000017500000000000015242043713012604 5ustar davedaveTie-Hash-Regex-2.0.0/lib/0000755000175000017500000000000015242043713013352 5ustar davedaveTie-Hash-Regex-2.0.0/lib/Tie/0000755000175000017500000000000015242043713014073 5ustar davedaveTie-Hash-Regex-2.0.0/lib/Tie/Hash/0000755000175000017500000000000015242043713014756 5ustar davedaveTie-Hash-Regex-2.0.0/lib/Tie/Hash/Regex.pm0000644000175000017500000001017115242043500016360 0ustar davedave =head1 NAME Tie::Hash::Regex - Match hash keys using Regular Expressions =head1 SYNOPSIS use Tie::Hash::Regex; my %h; tie %h, 'Tie::Hash::Regex'; $h{key} = 'value'; $h{key2} = 'another value'; $h{stuff} = 'something else'; print $h{key}; # prints 'value' print $h{2}; # prints 'another value' print $h{'^s'}; # prints 'something else' print tied(%h)->FETCH('k'); # prints 'value' and 'another value' delete $h{k}; # deletes $h{key} and $h{key2}; or (new! improved!) my %h : Regex; =head1 DESCRIPTION Someone asked on Perlmonks if a hash could do fuzzy matches on keys - this is the result. If there's no exact match on the key that you pass to the hash, then the key is treated as a regex and the first matching key is returned. You can force it to leap straight into the regex checking by passing a qr'ed regex into the hash like this: my $val = $h{qr/key/}; C and C also do regex matching. In the case of C I values matching your regex key will be deleted from the hash. One slightly strange thing. Obviously if you give a hash a regex key, then it's possible that more than one key will match (consider C<$h{qw/./}>). It might be nice to be able to do stuff like: my @vals = $h{$pat}; to get I matching values back. Unfortuately, Perl knows that a given hash key can only ever return one value and so forces scalar context on the C call when using the tied interface. You can get round this using the slightly less readable: my @vals = tied(%h)->FETCH($pat); =head2 ATTRIBUTE INTERFACE From version 0.06, you can use attributes to define your hash as being tied to Tie::Hash::Regex. You'll need to install the module Attribute::Handlers. Simply declare your hash using the attribute syntax: my %hash :Regex; =cut package Tie::Hash::Regex; use 5.006; use strict; use warnings; our ($VERSION, @ISA, @EXPORT, @EXPORT_OK); require Exporter; require Tie::Hash; use Attribute::Handlers autotie => { "__CALLER__::Regex" => __PACKAGE__ }; @ISA = qw(Exporter Tie::StdHash); @EXPORT = qw(); @EXPORT_OK =(); $VERSION = '2.0.0'; =head1 METHODS =head2 FETCH Get a value from the hash. If there isn't an exact match try a regex match. =cut sub FETCH { my $self = shift; my $key = shift; my $is_re = (ref $key eq 'Regexp'); return $self->{$key} if !$is_re && exists $self->{$key}; $key = _compile($key) unless $is_re; return unless defined $key; # NOTE: wantarray will _never_ be true when FETCH is called # using the standard hash semantics. I've put that piece # of code in for people who are happy using syntax like: # tied(%h)->FETCH(qr/$pat/); if (wantarray) { return @{$self}{ grep /$key/, keys %$self }; } else { /$key/ and return $self->{$_} for keys %$self; } return; } =head2 EXISTS See if a key exists in the hash. If there isn't an exact match try a regex match. =cut sub EXISTS { my $self = shift; my $key = shift; my $is_re = (ref $key eq 'Regexp'); return 1 if !$is_re && exists $self->{$key}; $key = _compile($key) unless $is_re; return unless defined $key; /$key/ && return 1 for keys %$self; return; } =head2 DELETE Delete a key from the hash. If there isn't an exact match try a regex match. =cut sub DELETE { my $self = shift; my $key = shift; my $is_re = (ref $key eq 'Regexp'); return delete $self->{$key} if !$is_re && exists $self->{$key}; $key = _compile($key) unless $is_re; return unless defined $key; for (keys %$self) { if (/$key/) { delete $self->{$_}; } } } sub _compile { my ($key) = @_; my $re = eval { qr/$key/ }; # This will be undef if the "eval" failed return $re; } 1; __END__ =head1 AUTHOR Dave Cross Thanks to the Perlmonks L for the original idea and to Jeff "japhy" Pinyan for some useful code suggestions. =head1 COPYRIGHT Copyright (C) 2001-8, Magnum Solutions Ltd. All Rights Reserved. =head1 LICENSE This script is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO perl(1). perltie(1). Tie::RegexpHash(1) =cut Tie-Hash-Regex-2.0.0/META.yml0000644000175000017500000000105315242043713014054 0ustar davedave--- abstract: unknown author: - unknown build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.76, CPAN::Meta::Converter version 2.150013' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Tie-Hash-Regex no_index: directory: - t - inc requires: Attribute::Handlers: '0' Test::More: '0' Tie::Hash: '0' version: v2.0.0 x_serialization_backend: 'CPAN::Meta::YAML version 0.020' Tie-Hash-Regex-2.0.0/README0000644000175000017500000000321513750513154013470 0ustar davedave Tie::Hash::Regex ---------------- NAME Tie::Hash::Regex DESCRIPTION WHAT IS Tie::Hash::Regex? Tie::Hash::Regex is a Perl module which extends the functionality of Perl hashes so that they can match regular expression keys. HOW DO I INSTALL IT? Tie::Hash::Regex uses the standard Perl module architecture and can therefore be installed using the standard Perl method which, in brief, goes something like this: gzip -cd Tie-Hash-Regex-X.XX.tar.gz | tar xvf - cd Tie-Hash-Regex-X.XX perl Build.PL Build Build test make install Where X.XX is the version number of the module which you are installing. If this doesn't work for you then creating a directory called Tie/Hash somewhere in your Perl library path (@INC) and copying the Regex.pm file into this directory should also do the trick. Since this has been published to CPAN, cpanm Tie::Hash::Regex will also install it for you along whatever dependency is not yet installed. WHERE IS THE DOCUMENTATION? All of the documentation is currently in POD format in the Regex.pm file. If you install the module using the standard method you should be able to read it by typing perldoc Tie::Hash::Regex at a comand prompt. LATEST VERSION The latest version of this module will always be available from CPAN. COPYRIGHT Copyright (c) 2001, Magnum Solutions Ltd. All Rights Reserved. This script is free software; you can redistribute it and/or modify it under the same terms as Perl itself. ANYTHING ELSE? If you have any further questions, please contact the author. AUTHOR Dave Cross Tie-Hash-Regex-2.0.0/META.json0000644000175000017500000000170115242043713014224 0ustar davedave{ "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.76, CPAN::Meta::Converter version 2.150013", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Tie-Hash-Regex", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Attribute::Handlers" : "0", "Test::More" : "0", "Tie::Hash" : "0" } } }, "release_status" : "stable", "version" : "v2.0.0", "x_serialization_backend" : "JSON::PP version 4.16" } Tie-Hash-Regex-2.0.0/MANIFEST0000644000175000017500000000032115242043655013736 0ustar davedaveChanges MANIFEST Build.PL Makefile.PL lib/Tie/Hash/Regex.pm t/test.t t/pod.t t/pod_coverage.t t/cvs-2026-77781.t README META.yml Module meta-data (added by MakeMaker) META.json Tie-Hash-Regex-2.0.0/t/0000755000175000017500000000000015242043713013047 5ustar davedaveTie-Hash-Regex-2.0.0/t/cvs-2026-77781.t0000644000175000017500000000524515242042537015122 0ustar davedaveuse strict; use warnings; use Test::More; use Tie::Hash::Regex; sub fresh { my %h; tie %h, 'Tie::Hash::Regex'; $h{alice} = 'record-A'; $h{bob} = 'record-B'; $h{carol} = 'record-C'; return \%h; } # # First make sure the normal behaviour still works. # { my $h = fresh(); is( $h->{alice}, 'record-A', 'exact lookup works', ); is( $h->{'^car'}, 'record-C', 'regex lookup works', ); is( $h->{'^zzz'}, undef, 'well-formed regex with no match returns undef', ); } # # Regression tests for CVE-2026-77781. # # A malformed regex used as a lookup key should be treated as a # non-match, rather than throwing an exception from FETCH, EXISTS # or DELETE. # my @payloads = ( '(', '[', '*', '+', '?', '\\', '(?<', '(?{', ); for my $payload (@payloads) { subtest "malformed pattern '$payload'" => sub { { my $h = fresh(); my ($value, $error); { local $@; eval { $value = $h->{$payload}; 1; } or $error = $@; } is( $error, undef, 'FETCH does not die', ); is( $value, undef, 'FETCH treats malformed pattern as no match', ); } { my $h = fresh(); my ($exists, $error); { local $@; eval { $exists = exists $h->{$payload}; 1; } or $error = $@; } is( $error, undef, 'EXISTS does not die', ); ok( !$exists, 'EXISTS treats malformed pattern as no match', ); } { my $h = fresh(); my ($deleted, $error); { local $@; eval { $deleted = delete $h->{$payload}; 1; } or $error = $@; } is( $error, undef, 'DELETE does not die', ); is( $deleted, undef, 'DELETE treats malformed pattern as no match', ); is_deeply( [sort keys %$h], [qw(alice bob carol)], 'failed DELETE leaves hash unchanged', ); } }; } done_testing; Tie-Hash-Regex-2.0.0/t/pod.t0000644000175000017500000000023413750514010014010 0ustar davedaveuse strict; use warnings; use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Tie-Hash-Regex-2.0.0/t/pod_coverage.t0000644000175000017500000000027413750513775015710 0ustar davedaveuse strict; use warnings; use Test::More; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; all_pod_coverage_ok(); Tie-Hash-Regex-2.0.0/t/test.t0000644000175000017500000000122113750514101014203 0ustar davedaveuse strict; use warnings; use Test::More; BEGIN { use_ok 'Tie::Hash::Regex' }; my %hash : Regex; $hash{key} = 'value'; $hash{key2} = 'another value'; $hash{stuff} = 'something else'; my $x = 'f'; is($hash{key}, 'value'); is($hash{'^s'}, 'something else'); is($hash{qr'^s'}, 'something else'); ok(not defined $hash{blah}); is($hash{$x}, 'something else'); my @vals = tied(%hash)->FETCH('k'); is(@vals, 2); delete $hash{stuff}; is(keys %hash, 2); ok(exists $hash{key}); ok(exists $hash{k}); ok(exists $hash{qr'^k'}); ok(not exists $hash{zz}); delete $hash{2}; my @k = keys %hash; is(@k, 1); delete $hash{qr/^k/}; ok(not keys %hash); done_testing(); Tie-Hash-Regex-2.0.0/Makefile.PL0000644000175000017500000000067414003515124014557 0ustar davedave# Note: this file was auto-generated by Module::Build::Compat version 0.4231 require 5.006000; use ExtUtils::MakeMaker; WriteMakefile ( 'NAME' => 'Tie::Hash::Regex', 'VERSION_FROM' => 'lib/Tie/Hash/Regex.pm', 'PREREQ_PM' => { 'Attribute::Handlers' => 0, 'Test::More' => 0, 'Tie::Hash' => 0 }, 'INSTALLDIRS' => 'site', 'EXE_FILES' => [], 'PL_FILES' => {} ) ; Tie-Hash-Regex-2.0.0/Build.PL0000644000175000017500000000176414553735623014124 0ustar davedaveuse Module::Build; my $build = Module::Build->new( module_name => 'Tie::Hash::Regex', license => 'perl', requires => { perl => '5.6.0', 'Tie::Hash' => 0, 'Attribute::Handlers' => 0, }, build_requires => { 'Test::More' => 0, }, build_recommends => { 'Test::Pod' => 0, 'Test::Pod::Coverage' => 0, }, create_makefile_pl => 'traditional', meta_merge => { 'meta-spec' => { version => 2 }, resources => { repository => { type => 'git', url => 'git://github.com/davorg-cpan/tie-hash-regex.git', web => 'https://github.com/davorg-cpan/tie-hash-regex', }, bugtracker => { web => 'https://github.com/davorg-cpan/tie-hash-regex/issues', }, }, }, ); $build->create_build_script; Tie-Hash-Regex-2.0.0/Changes0000644000175000017500000000652515242043573014113 0ustar davedave2026-08-21 Dave Cross * Version 2.0.0 * Fix CVE-2026-77781 2021-01-25 Dave Cross * Version 1.14 * Added bugtracker to metadata * Added GitHub CI 2020-11-04 Dave Cross * Version 1.13 * Added repo details 2018-02-23 Dave Cross * Build.PL: Missed a version number. * README, README.xml, lib/Tie/Hash/Regex.pm: Replace README.xml with plain text README. Bump version. * .travis.yml: Added more Perl versions to .travis.yml. 2016-10-04 Dave Cross * t/slices.t: Skip the skip_all * t/slices.t: More tests that won't compile * t/slices.t: Comment out TODO blocks As they still need to compile on older versions of Perl. 2016-05-18 Dave Cross * t/slices.t: Skip slice tests if hash slices are unsupported. * t/test.t: Use 'is' instead of 'ok' when appropriate. * t/slices.t: Better tests (and mark some as TODO) * lib/Tie/Hash/Regex.pm: Fix some typos that have been there for a very long time 2015-08-17 Theodorus Van Hoesel * t/slices.t: added test for 5.20 where regex should return more than one 2015-07-18 Dave Cross * .travis.yml: Added .travis.yml 2015-07-17 Dave Cross * .gitignore: Added .gitignore * MANIFEST: Added META.json to MANIFEST 2009-02-21 Dave Cross * lib/Tie/Hash/Regex.pm: Changed versioning system. 2008-06-30 Dave Cross * README.xml: Typo 2008-03-14 Dave Cross * README.xml: Fixed broken XML 2008-03-08 Dave Cross * MANIFEST: Added Build.PL to MANIFEST * MANIFEST: Moved Regex.pm in MANIFEST * lib/Tie/Hash/Regex.pm: Removed old CVS log. Switched references from dave.org.uk to mag-sol.com. Forced use of Perl >= 5.6. Used "our" instead of "use vars". Added "use warnings". Added LICENSE (sic) section. * t/pod.t, t/test.t: Switched to using Test::More. Removed old Test comments. Added t/pod.t. * MANIFEST: Removed COPYING from MANIFEST * COPYING: Removed COPYING * Regex.pm => lib/Tie/Hash/Regex.pm: Moved Regex.pm to lib * Build.PL, Makefile.PL: Switch from Makefile.PL to Build.PL 2006-06-01 Dave Cross * Regex.pm: Raising to version 1.0 * MANIFEST, t/pod_coverage.t: Added t/pod_coverage.t 2004-10-23 Dave Cross * Regex.pm, t/test.t: Improve test coverage. 2004-05-22 Dave Cross * t/test.t: Added some new tests 2004-05-12 Dave Cross * COPYING, MANIFEST, Makefile.PL, README.xml: Added various files to cvs * t/test.t: Added test file to CVS 2002-09-23 Dave Cross * Regex.pm: Fixed to work with Perl 5.8.0. 2002-07-28 Dave Cross * Regex.pm: Applied "exists" hash from Steffen M�ller. 2002-07-12 Dave Cross * Regex.pm: Corrected Attribute::Handler dependencies 2001-12-09 Dave Cross * Regex.pm: Doc fixes. * Regex.pm: Added Attribute::Handlers interface. 2001-09-03 Dave Cross * Regex.pm: Minor fixes. 2001-09-02 Dave Cross * Regex.pm: Added ref to Tie::RegexpHash. 2001-06-03 Dave Cross * Regex.pm: Put into RCS.