util/perl/OpenSSL/OID.pm

   1 # Copyright 2016-2019 The OpenSSL Project Authors. All Rights Reserved.
   2 #
   3 # Licensed under the Apache License 2.0 (the "License").  You may not use
   4 # this file except in compliance with the License.  You can obtain a copy
   5 # in the file LICENSE in the source distribution or at
   6 # https://www.openssl.org/source/license.html
   7
   8 # Author note: this is originally RL::ASN1::OID,
   9 # repurposed by the author for OpenSSL use.
  10
  11 package OpenSSL::OID;
  12
  13 use 5.10.0;
  14 use strict;
  15 use warnings;
  16 use Carp;
  17
  18 use Exporter;
  19 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  20 @ISA = qw(Exporter);
  21 @EXPORT = qw(parse_oid encode_oid register_oid
  22              registered_oid_arcs registered_oid_leaves);
  23 @EXPORT_OK = qw(encode_oid_nums);
  24
  25 use List::Util;
  26
  27 =head1 NAME
  28
  29 OpenSSL::OID - an OBJECT IDENTIFIER parser / encoder
  30
  31 =head1 VERSION
  32
  33 Version 0.1
  34
  35 =cut
  36
  37 our $VERSION = '0.1';
  38
  39
  40 =head1 SYNOPSIS
  41
  42     use OpenSSL::OID;
  43
  44     # This gives the array ( 1 2 840 113549 1 1 )
  45     my @nums = parse_oid('{ pkcs-1 1 }');
  46
  47     # This gives the array of DER encoded bytes for the OID, i.e.
  48     # ( 42, 134, 72, 134, 247, 13, 1, 1 )
  49     my @bytes = encode_oid('{ pkcs-1 1 }');
  50
  51     # This registers a name with an OID.  It's saved internally and
  52     # serves as repository of names for further parsing, such as 'pkcs-1'
  53     # in the strings used above.
  54     register_object('pkcs-1', '{ pkcs 1 }');
  55
  56
  57     use OpenSSL::OID qw(:DEFAULT encode_oid_nums);
  58
  59     # This does the same as encode_oid(), but takes the output of
  60     # parse_oid() as input.
  61     my @bytes = encode_oid_nums(@nums);
  62
  63 =head1 EXPORT
  64
  65 The functions parse_oid and encode_oid are exported by default.
  66 The function encode_oid_nums() can be exported explicitly.
  67
  68 =cut
  69
  70 ######## REGEXPS
  71
  72 # ASN.1 object identifiers come in two forms: 1) the bracketed form
  73 #(referred to as ObjectIdentifierValue in X.690), 2) the dotted form
  74 #(referred to as XMLObjIdentifierValue in X.690)
  75 #
  76 # examples of 1 (these are all the OID for rsaEncrypted):
  77 #
  78 # { iso (1) 2 840 11349 1 1 }
  79 # { pkcs 1 1 }
  80 # { pkcs1 1 }
  81 #
  82 # examples of 2:
  83 #
  84 # 1.2.840.113549.1.1
  85 # pkcs.1.1
  86 # pkcs1.1
  87 #
  88 my $identifier_re = qr/[a-z](?:[-_A-Za-z0-9]*[A-Za-z0-9])?/;
  89 # The only difference between $objcomponent_re and $xmlobjcomponent_re is
  90 # the separator in the top branch.  Each component is always parsed in two
  91 # groups, so we get a pair of values regardless.  That's the reason for the
  92 # empty parentheses.
  93 # Because perl doesn't try to do an exhaustive try of every branch it rather
  94 # stops on the first that matches, we need to have them in order of longest
  95 # to shortest where there may be ambiguity.
  96 my $objcomponent_re = qr/(?|
  97                              (${identifier_re}) \s* \((\d+)\)
  98                          |
  99                              (${identifier_re}) ()
 100                          |
 101                              ()(\d+)
 102                          )/x;
 103 my $xmlobjcomponent_re = qr/(?|
 104                                 (${identifier_re}) \. \((\d+)\)
 105                             |
 106                                 (${identifier_re}) ()
 107                             |
 108                                 () (\d+)
 109                             )/x;
 110
 111 my $obj_re =
 112     qr/(?: \{ \s* (?: ${objcomponent_re} \s+ )* ${objcomponent_re} \s* \} )/x;
 113 my $xmlobj_re =
 114     qr/(?: (?: ${xmlobjcomponent_re} \. )* ${xmlobjcomponent_re} )/x;
 115
 116 ######## NAME TO OID REPOSITORY
 117
 118 # Recorded OIDs, to support things like '{ pkcs1 1 }'
 119 # Do note that we don't currently support relative OIDs
 120 #
 121 # The key is the identifier.
 122 #
 123 # The value is a hash, composed of:
 124 # type => 'arc' | 'leaf'
 125 # nums => [ LIST ]
 126 # Note that the |type| always starts as a 'leaf', and may change to an 'arc'
 127 # on the fly, as new OIDs are parsed.
 128 my %name2oid = ();
 129
 130 ########
 131
 132 =head1 SUBROUTINES/METHODS
 133
 134 =over 4
 135
 136 =item parse_oid()
 137
 138 TBA
 139
 140 =cut
 141
 142 sub parse_oid {
 143     my $input = shift;
 144
 145     croak "Invalid extra arguments" if (@_);
 146
 147     # The components become a list of ( identifier, number ) pairs,
 148     # where they can also be the empty string if they are not present
 149     # in the input.
 150     my @components;
 151     if ($input =~ m/^\s*(${obj_re})\s*$/x) {
 152         my $oid = $1;
 153         @components = ( $oid =~ m/${objcomponent_re}\s*/g );
 154     } elsif ($input =~ m/^\s*(${xmlobj_re})\s*$/) {
 155         my $oid = $1;
 156         @components = ( $oid =~ m/${xmlobjcomponent_re}\.?/g );
 157     }
 158
 159     croak "Invalid ASN.1 object '$input'" unless @components;
 160     die "Internal error when parsing '$input'"
 161         unless scalar(@components) % 2 == 0;
 162
 163     # As we currently only support a name without number as first
 164     # component, the easiest is to have a direct look at it and
 165     # hack it.
 166     my @first = List::Util::pairmap {
 167         return $b if $b ne '';
 168         return @{$name2oid{$a}->{nums}} if $a ne '' && defined $name2oid{$a};
 169         croak "Undefined identifier $a" if $a ne '';
 170         croak "Empty OID element (how's that possible?)";
 171     } ( @components[0..1] );
 172
 173     my @numbers =
 174         (
 175          @first,
 176          List::Util::pairmap {
 177              return $b if $b ne '';
 178              croak "Unsupported relative OID $a" if $a ne '';
 179              croak "Empty OID element (how's that possible?)";
 180          } @components[2..$#components]
 181         );
 182
 183     # If the first component has an identifier and there are other
 184     # components following it, we change the type of that identifier
 185     # to 'arc'.
 186     if (scalar @components > 2
 187         && $components[0] ne ''
 188         && defined $name2oid{$components[0]}) {
 189         $name2oid{$components[0]}->{type} = 'arc';
 190     }
 191
 192     return @numbers;
 193 }
 194
 195 =item encode_oid()
 196
 197 =cut
 198
 199 # Forward declaration
 200 sub encode_oid_nums;
 201 sub encode_oid {
 202     return encode_oid_nums parse_oid @_;
 203 }
 204
 205 =item register_oid()
 206
 207 =cut
 208
 209 sub register_oid {
 210     my $name = shift;
 211     my @nums = parse_oid @_;
 212
 213     if (defined $name2oid{$name}) {
 214         my $str1 = join(',', @nums);
 215         my $str2 = join(',', @{$name2oid{$name}->{nums}});
 216
 217         croak "Invalid redefinition of $name with different value"
 218             unless $str1 eq $str2;
 219     } else {
 220         $name2oid{$name} = { type => 'leaf', nums => [ @nums ] };
 221     }
 222 }
 223
 224 =item registered_oid_arcs()
 225
 226 =item registered_oid_leaves()
 227
 228 =cut
 229
 230 sub _registered_oids {
 231     my $type = shift;
 232
 233     return grep { $name2oid{$_}->{type} eq $type } keys %name2oid;
 234 }
 235
 236 sub registered_oid_arcs {
 237     return _registered_oids( 'arc' );
 238 }
 239
 240 sub registered_oid_leaves {
 241     return _registered_oids( 'leaf' );
 242 }
 243
 244 =item encode_oid_nums()
 245
 246 =cut
 247
 248 # Internal helper.  It takes a numeric OID component and generates the
 249 # DER encoding for it.
 250 sub _gen_oid_bytes {
 251     my $num = shift;
 252     my $cnt = 0;
 253
 254     return ( $num ) if $num < 128;
 255     return ( ( map { $_ | 0x80 } _gen_oid_bytes($num >> 7) ), $num & 0x7f );
 256 }
 257
 258 sub encode_oid_nums {
 259     my @numbers = @_;
 260
 261     croak 'Invalid OID values: ( ', join(', ', @numbers), ' )'
 262         if (scalar @numbers < 2
 263             || $numbers[0] < 0 || $numbers[0] > 2
 264             || $numbers[1] < 0 || $numbers[1] > 39);
 265
 266     my $first = shift(@numbers) * 40 + shift(@numbers);
 267     @numbers = ( $first, map { _gen_oid_bytes($_) } @numbers );
 268
 269     return @numbers;
 270 }
 271
 272 =back
 273
 274 =head1 AUTHOR
 275
 276 Richard levitte, C<< <richard at levitte.org> >>
 277
 278 =cut
 279
 280 ######## UNIT TESTING
 281
 282 use Test::More;
 283
 284 sub TEST {
 285     # Order is important, so we make it a pairwise list
 286     my @predefined =
 287         (
 288          'pkcs' => '1.2.840.113549',
 289          'pkcs-1' => 'pkcs.1',
 290         );
 291
 292     my %good_cases =
 293         (
 294          ' 1.2.840.113549.1.1 ' => [ 42, 134, 72, 134, 247, 13, 1, 1 ],
 295          'pkcs.1.1' => [ 42, 134, 72, 134, 247, 13, 1, 1 ],
 296          'pkcs-1.1' => [ 42, 134, 72, 134, 247, 13, 1, 1 ],
 297          ' { iso (1) 2 840 113549 1 1 } ' => [ 42, 134, 72, 134, 247, 13, 1, 1 ],
 298          '{ pkcs 1 1 } ' => [ 42, 134, 72, 134, 247, 13, 1, 1 ],
 299          '{pkcs-1 1 }' => [ 42, 134, 72, 134, 247, 13, 1, 1 ],
 300         );
 301     my @bad_cases =
 302         (
 303          ' { 1.2.840.113549.1.1 } ',
 304         );
 305
 306     plan tests =>
 307         scalar ( @predefined ) / 2
 308         + scalar ( keys %good_cases )
 309         + scalar @bad_cases;
 310
 311     note 'Predefine a few names OIDs';
 312     foreach my $pair ( List::Util::pairs @predefined ) {
 313         ok( defined eval { register_oid(@$pair) },
 314             "Registering $pair->[0] => $pair->[1]" );
 315     }
 316
 317     note 'Good cases';
 318     foreach ( keys %good_cases ) {
 319         subtest "Checking '$_'" => sub {
 320             my $oid = shift;
 321
 322             plan tests => 5;
 323
 324             my (@l, @e);
 325
 326             ok( scalar (@l = eval { parse_oid $oid }) > 0,
 327                 "Parsing" );
 328             diag $@ unless @l;
 329             ok( scalar (@e = eval { encode_oid_nums @l }) > 0,
 330                 "Encoding via encode_oid_nums()" );
 331             diag $@ unless @e;
 332             is_deeply(\@e, $good_cases{$oid}, "Checking encoding");
 333             note "'$oid' => ", join(', ', @e) if @e;
 334
 335             ok( scalar (@e = eval { encode_oid $oid }) > 0,
 336                 "Encoding directly" );
 337             diag $@ unless @e;
 338             is_deeply(\@e, $good_cases{$oid}, "Checking encoding");
 339             note "'$oid' => ", join(', ', @e) if @e;
 340         },
 341         $_;
 342     }
 343
 344     note 'Bad cases';
 345     foreach ( @bad_cases ) {
 346         subtest "Checking '$_'" => sub {
 347             my $oid = shift;
 348
 349             plan tests => 2;
 350
 351             my (@l, @e);
 352
 353             ok( scalar (@l = eval { parse_oid $oid }) == 0,
 354                 "Parsing '$oid'" );
 355             note $@ unless @l;
 356             ok( scalar (@e = eval { encode_oid_nums @l }) == 0,
 357                 "Encoding '$oid'" );
 358             note $@ unless @e;
 359             note "'$oid' => ", join(', ', @e) if @e;
 360         },
 361         $_;
 362     }
 363 }
 364
 365 1; # End of OpenSSL::OID