File Coverage

blib/lib/No/Worries/DN.pm
Criterion Covered Total %
statement 52 55 94.5
branch 16 20 80.0
condition 0 3 0.0
subroutine 11 11 100.0
pod 2 2 100.0
total 81 91 89.0


line stmt bran cond sub pod time code
1             #+##############################################################################
2             # #
3             # File: No/Worries/DN.pm #
4             # #
5             # Description: Distinguished Names handling without worries #
6             # #
7             #-##############################################################################
8              
9             #
10             # module definition
11             #
12              
13             package No::Worries::DN;
14 1     1   68917 use strict;
  1         11  
  1         30  
15 1     1   5 use warnings;
  1         1  
  1         93  
16             our $VERSION = "1.7";
17             our $REVISION = sprintf("%d.%02d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/);
18              
19             #
20             # used modules
21             #
22              
23 1     1   423 use No::Worries::Die qw(dief);
  1         3  
  1         6  
24 1     1   7 use No::Worries::Export qw(export_control);
  1         2  
  1         6  
25 1     1   6 use Params::Validate qw(validate_pos :types);
  1         1  
  1         163  
26              
27             #
28             # constants
29             #
30              
31 1     1   7 use constant FORMAT_RFC2253 => "rfc2253";
  1         2  
  1         57  
32 1     1   6 use constant FORMAT_JAVA => "java";
  1         1  
  1         61  
33 1     1   6 use constant FORMAT_OPENSSL => "openssl";
  1         3  
  1         842  
34              
35             #
36             # global variables
37             #
38              
39             our(
40             %_Map, # map of known attribute types
41             $_TypeRE, # regexp for a valid attribute type
42             $_ValueRE, # regexp for a valid attribute value
43             );
44              
45             foreach my $type (qw(Email emailAddress EMAILADDRESS)) {
46             $_Map{$type} = $type;
47             }
48              
49             foreach my $type (qw(C CN DC L O OU ST)) {
50             $_Map{$type} = $_Map{lc($type)} = $type;
51             }
52              
53             $_TypeRE = join("|", keys(%_Map));
54              
55             $_ValueRE = "[" .
56             "0-9a-zA-Z" . # alphanumerical
57             "\\x20" . # space
58             "\\x27" . # quote
59             "\\x28" . # left parenthesis
60             "\\x29" . # right parenthesis
61             "\\x2d" . # dash
62             "\\x2e" . # dot
63             "\\x2f" . # slash
64             "\\x3a" . # colon
65             "\\x40" . # at sign
66             "\\x5f" . # underscore
67             "\\xa0-\\xff" . # some high-bit characters that may come from ISO-8859-1
68             "]+";
69              
70             #
71             # parse a string containing a DN and return an array reference
72             #
73              
74             sub dn_parse ($) {
75 12     12 1 5391 my($string) = @_;
76 12         22 my($sep, @list, @dn);
77              
78 12         367 validate_pos(@_, { type => SCALAR });
79 11 100       134 if ($string =~ m/^(\/[a-z]+=[^=]*){3,}$/i) {
    100          
    100          
80 3         5 $sep = "/";
81             } elsif ($string =~ m/^[a-z]+=[^=]*(,[a-z]+=[^=]*){2,}$/i) {
82 1         3 $sep = ",";
83             } elsif ($string =~ m/^[a-z]+=[^=]*(, [a-z]+=[^=]*){2,}$/i) {
84 4         9 $sep = ", ";
85             } else {
86 3         12 dief("unexpected DN: %s", $string);
87             }
88 8         82 @list = split(/$sep/, $string);
89 8 100       26 shift(@list) if $sep eq "/";
90 8         18 @dn = ();
91 8         14 foreach my $attr (@list) {
92 37 50 0     257 if ($attr =~ /^($_TypeRE)=($_ValueRE)$/) {
    0          
93             # type=value
94 37         139 push(@dn, "$_Map{$1}=$2");
95             } elsif (@dn and $attr =~ /^($_ValueRE)$/) {
96             # value only, assumed to come from previous attribute
97 0         0 $dn[-1] .= $sep . $attr;
98             } else {
99 0         0 dief("invalid DN: %s", $string);
100             }
101             }
102 8 100       20 @dn = reverse(@dn) if $sep eq "/";
103 8         26 return(\@dn);
104             }
105              
106             #
107             # convert the given parsed DN into a string
108             #
109              
110             sub dn_string ($$) {
111 4     4 1 1562 my($dn, $format) = @_;
112              
113 4         188 validate_pos(@_, { type => ARRAYREF }, { type => SCALAR });
114 3 100       16 return(join(",", @{ $dn })) if $format eq FORMAT_RFC2253;
  1         5  
115 2 100       6 return(join(", ", @{ $dn })) if $format eq FORMAT_JAVA;
  1         6  
116 1 50       4 return(join("/", "", reverse(@{ $dn }))) if $format eq FORMAT_OPENSSL;
  1         6  
117 0         0 dief("unsupported DN format: %s", $format);
118             }
119              
120             #
121             # export control
122             #
123              
124             sub import : method {
125 1     1   11 my($pkg, %exported);
126              
127 1         2 $pkg = shift(@_);
128 1         7 grep($exported{$_}++, map("dn_$_", qw(parse string)));
129 1         6 export_control(scalar(caller()), $pkg, \%exported, @_);
130             }
131              
132             1;
133              
134             __DATA__