File Coverage

blib/lib/POE/Event/Message/UniqueID.pm
Criterion Covered Total %
statement 48 60 80.0
branch 11 24 45.8
condition 3 7 42.8
subroutine 10 10 100.0
pod 1 4 25.0
total 73 105 69.5


line stmt bran cond sub pod time code
1             # -*- Perl -*-
2             #
3             # File: POE/Event/Message/UniqueID.pm
4             # Desc: Generate a guaranteed unique message identifier
5             # Date: Mon Oct 10 10:10:59 2005
6             # Stat: Prototype, Experimental
7             #
8             package POE::Event::Message::UniqueID;
9 3     3   42 use 5.006;
  3         10  
  3         111  
10 3     3   13 use strict;
  3         7  
  3         76  
11 3     3   14 use warnings;
  3         31  
  3         141  
12              
13             our $PACK = __PACKAGE__;
14             our $VERSION = '0.03';
15             ### @ISA = qw( );
16              
17 3     3   2648 use POSIX;
  3         31329  
  3         22  
18 3     3   25239 use Time::HiRes; # comment this line to use CORE::time() and rand()
  3         6239  
  3         21  
19             # uncomment to use gettimeofday() -- the better choice
20             my($host,$pid);
21             my($time,$ident,@prior) = ("","",());
22             my($secs,$msecs,$rand) = (0,0,0);
23             my($errs,$mesg,$count) = (0,"",0);
24              
25             sub import
26 3     3   8 { my($class,@args) = @_;
27 3         12 $class->buildIdentityGenerator( @args ); # How will we create IDs today?
28             }
29              
30             *generate = \&genUniqueIdent;
31             *generateUniqueID = \&genUniqueIdent;
32              
33             sub buildIdentityGenerator
34 3     3 0 5 { my($class,$debug) = @_;
35              
36 3         6 $host = eval { (POSIX::uname)[1] };
  3         42  
37 3         13 $pid = $$;
38              
39 3 50       16 print "-" x 55 ."\n" if $debug;
40              
41 3 50       13 if ( exists $INC{'Time/HiRes.pm'} ) {
42 3 50       12 print "Will use Time::HiRes::time() to generate IDs\n" if $debug;
43              
44 3     1000 0 938 eval('sub genUniqueIdent {
  1000         3063  
  1000         5215  
45             ($secs,$msecs) = Time::HiRes::gettimeofday();
46             ( $host ."-". unpack("H*", pack("N*", $secs,$msecs,$pid)) );
47             }
48             ');
49              
50             } else {
51 0 0       0 print "Will use CORE::time() and rand() to generate IDs\n" if $debug;
52 0 0       0 print "(note that there is a slight chance of duplicates)\n" if $debug;
53              
54 0         0 eval('sub genUniqueIdent {
55             my $limit = 1000000; # good distribution for uniqueness?
56             ($time,$rand) = ( CORE::time(), rand($limit) );
57             ( $host ."-". unpack("H*", pack("N*", $time,$rand,$pid)) );
58             }
59             ');
60             }
61 3         8962 return;
62             }
63              
64             my $dupErrCount;
65 1     1 0 10 sub dupErrCount { $dupErrCount };
66              
67             sub verifyGenerateUniqueID
68 1     1 1 16 { my($class,$debug,$max) = @_;
69              
70 1   50     9 $debug ||= 0;
71 1   50     6 $max ||= 1000;
72              
73 1 50       8 if ($debug) {
74 0         0 print "-" x 55 ."\n";
75 0         0 print "Generating $max IDs to verify uniqueness...\n";
76 0         0 print " host = $host\n";
77 0         0 print " pid = $pid\n";
78 0         0 print " time = ". time() ."\n";
79             }
80              
81 1         4 foreach (1..$max) {
82              
83 1000         29616 $ident = genUniqueIdent(); # This is a generated subroutine
84              
85 1000 50       433471 if ( grep(/^$ident$/, @prior) ) {
86 0         0 ($errs,$mesg) = ($errs +1, "duplicate ID!");
87 0         0 print " ident = $ident $mesg\n";
88             } else {
89 1000         1780 ($mesg) = ("unique ID!");
90 1000         1597 push @prior, $ident;
91 1000 100       1650 if ($count) {
92 999 50       2401 print " ident = $ident $mesg\n" if $debug > 1;
93             } else {
94 1 50       5 print " ident = $ident (example)\n" if $debug > 1;
95             }
96             }
97 1000         1447 $count++;
98             }
99 1         4 $dupErrCount = $errs;
100              
101 1         472 print "-" x 55 ."\n";
102 1         124 print "IDs Generated: $count Duplicates: $errs\n";
103              
104 1 50 33     10 if ( $errs and exists $INC{'Time/HiRes.pm'} ) {
    50          
105 0         0 print "OUCH: the unique ID generator needs some work!!\n";
106             } elsif ( $errs ) {
107 0         0 print "Oops: Try using 'Time::HiRes' for better results!\n";
108             }
109 1         112 print "-" x 55 ."\n";
110 1         7 return;
111             }
112             #_________________________
113             1; # Required by require()
114              
115             __END__