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