File Coverage

blib/lib/Data/Unique/Name.pm
Criterion Covered Total %
statement 32 32 100.0
branch 7 10 70.0
condition n/a
subroutine 8 8 100.0
pod 2 3 66.6
total 49 53 92.4


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2             #-------------------------------------------------------------------------------
3             # Generate a unique but stable name from a string
4             # Philip R Brenan at gmail dot com, Appa Apps Ltd, 2016
5             #-------------------------------------------------------------------------------
6             # podDocumentation
7              
8             package Data::Unique::Name;
9             require v5.16.0;
10 1     1   480 use warnings FATAL => qw(all);
  1         3  
  1         45  
11 1     1   8 use strict;
  1         2  
  1         27  
12 1     1   17 use Carp;
  1         3  
  1         346  
13              
14             our $VERSION = '20170809';
15              
16             #1 Constructor
17             sub new($) # Construct a new set of unique names
18 1     1 1 3 {my ($length) = @_; # Maximum length of generated names
19 1         20 bless {length=>$length, count=>{}}
20             }
21              
22             #1 Methods
23             sub generateUniqueName($$) # Generate a unique name corresponding to a string
24 10     10 1 21 {my ($set, $string) = @_; # Set of unique strings, string
25 10         18 my $l = $set->{length};
26 10         34 my $s = $string =~ s/\W//gsr =~ s/\d+\Z//sr;
27 10 100       31 $s = substr($s, 0, $l) if length($s) > $l;
28 10 100       28 if (my $n = $set->{count}{$s})
29 8         11 {$set->{count}{$s}++;
30 8         33 return $s.$n;
31             }
32 2         4 $set->{count}{$s}++;
33 2         9 $s
34             }
35              
36             # podDocumentation
37              
38             #-------------------------------------------------------------------------------
39             # Export
40             #-------------------------------------------------------------------------------
41              
42             require Exporter;
43              
44 1     1   9 use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  1         2  
  1         321  
45              
46             @ISA = qw(Exporter);
47             @EXPORT = qw();
48             @EXPORT_OK = qw();
49             %EXPORT_TAGS = (all=>[@EXPORT, @EXPORT_OK]);
50              
51             =encoding utf-8
52              
53             =head1 Name
54              
55             Data::Unique::Name - Generate a unique but stable name from a string
56              
57             =head1 Synopsis
58              
59             use Data::Unique::Name;
60              
61             my $u = Data::Unique::Name::new(4);
62              
63             ok $u->generateUniqueName("aaaa") eq "aaaa";
64             ok $u->generateUniqueName("aaaa") eq "aaaa1";
65             ok $u->generateUniqueName("aaaa1") eq "aaaa2";
66             ok $u->generateUniqueName("aaaa2") eq "aaaa3";
67             ok $u->generateUniqueName("aaaab") eq "aaaa4";
68             ok $u->generateUniqueName("a a a a b") eq "aaaa5";
69             ok $u->generateUniqueName("a-a(a)/ab") eq "aaaa6";
70             ok $u->generateUniqueName("bbbbb") eq "bbbb";
71             ok $u->generateUniqueName("bbbbbb") eq "bbbb1";
72             ok $u->generateUniqueName("bbbbbbb") eq "bbbb2";
73              
74             =head1 Description
75              
76             =head2 Constructor
77              
78             =head3 new
79              
80             Construct a new set of unique names
81              
82             1 $length Maximum length of generated names # File name to be used on S3
83              
84             =head2 Methods
85              
86             =head3 generateUniqueName
87              
88             Generate a unique name corresponding to a string
89              
90             1 $set Set of unique strings
91             2 $string String
92              
93              
94             =head1 Index
95              
96              
97             L
98              
99             L
100              
101             =head1 Installation
102              
103             This module is written in 100% Pure Perl and, thus, it is easy to read, use,
104             modify and install.
105              
106             Standard Module::Build process for building and installing modules:
107              
108             perl Build.PL
109             ./Build
110             ./Build test
111             ./Build install
112              
113             =head1 Author
114              
115             L
116              
117             L
118              
119             =head1 Copyright
120              
121             Copyright (c) 2016-2017 Philip R Brenan.
122              
123             This module is free software. It may be used, redistributed and/or modified
124             under the same terms as Perl itself.
125              
126             =cut
127              
128              
129             # Tests and documentation
130              
131             sub test
132 1     1 0 17 {my $p = __PACKAGE__;
133 1 50       82 return if eval "eof(${p}::DATA)";
134 1         73 my $s = eval "join('', <${p}::DATA>)";
135 1 50       9 $@ and die $@;
136 1     1   596 eval $s;
  1         51969  
  1         9  
  1         78  
137 1 50       343 $@ and die $@;
138             }
139              
140             test unless caller;
141              
142             1;
143             __DATA__