2
0

OID.pm 7.6 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307
  1. # Copyright 2016-2020 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. # Author note: this is originally RL::ASN1::OID,
  8. # repurposed by the author for OpenSSL use.
  9. package OpenSSL::OID;
  10. use 5.10.0;
  11. use strict;
  12. use warnings;
  13. use Carp;
  14. use Exporter;
  15. use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  16. @ISA = qw(Exporter);
  17. @EXPORT = qw(parse_oid encode_oid register_oid
  18. registered_oid_arcs registered_oid_leaves);
  19. @EXPORT_OK = qw(encode_oid_nums);
  20. # Unfortunately, the pairwise List::Util functionality came with perl
  21. # v5.19.3, and I want to target absolute compatibility with perl 5.10
  22. # and up. That means I have to implement quick pairwise functions here.
  23. #use List::Util;
  24. sub _pairs (@);
  25. sub _pairmap (&@);
  26. =head1 NAME
  27. OpenSSL::OID - an OBJECT IDENTIFIER parser / encoder
  28. =head1 VERSION
  29. Version 0.1
  30. =cut
  31. our $VERSION = '0.1';
  32. =head1 SYNOPSIS
  33. use OpenSSL::OID;
  34. # This gives the array ( 1 2 840 113549 1 1 )
  35. my @nums = parse_oid('{ pkcs-1 1 }');
  36. # This gives the array of DER encoded bytes for the OID, i.e.
  37. # ( 42, 134, 72, 134, 247, 13, 1, 1 )
  38. my @bytes = encode_oid('{ pkcs-1 1 }');
  39. # This registers a name with an OID. It's saved internally and
  40. # serves as repository of names for further parsing, such as 'pkcs-1'
  41. # in the strings used above.
  42. register_object('pkcs-1', '{ pkcs 1 }');
  43. use OpenSSL::OID qw(:DEFAULT encode_oid_nums);
  44. # This does the same as encode_oid(), but takes the output of
  45. # parse_oid() as input.
  46. my @bytes = encode_oid_nums(@nums);
  47. =head1 EXPORT
  48. The functions parse_oid and encode_oid are exported by default.
  49. The function encode_oid_nums() can be exported explicitly.
  50. =cut
  51. ######## REGEXPS
  52. # ASN.1 object identifiers come in two forms: 1) the bracketed form
  53. #(referred to as ObjectIdentifierValue in X.690), 2) the dotted form
  54. #(referred to as XMLObjIdentifierValue in X.690)
  55. #
  56. # examples of 1 (these are all the OID for rsaEncrypted):
  57. #
  58. # { iso (1) 2 840 11349 1 1 }
  59. # { pkcs 1 1 }
  60. # { pkcs1 1 }
  61. #
  62. # examples of 2:
  63. #
  64. # 1.2.840.113549.1.1
  65. # pkcs.1.1
  66. # pkcs1.1
  67. #
  68. my $identifier_re = qr/[a-z](?:[-_A-Za-z0-9]*[A-Za-z0-9])?/;
  69. # The only difference between $objcomponent_re and $xmlobjcomponent_re is
  70. # the separator in the top branch. Each component is always parsed in two
  71. # groups, so we get a pair of values regardless. That's the reason for the
  72. # empty parentheses.
  73. # Because perl doesn't try to do an exhaustive try of every branch it rather
  74. # stops on the first that matches, we need to have them in order of longest
  75. # to shortest where there may be ambiguity.
  76. my $objcomponent_re = qr/(?|
  77. (${identifier_re}) \s* \((\d+)\)
  78. |
  79. (${identifier_re}) ()
  80. |
  81. ()(\d+)
  82. )/x;
  83. my $xmlobjcomponent_re = qr/(?|
  84. (${identifier_re}) \. \((\d+)\)
  85. |
  86. (${identifier_re}) ()
  87. |
  88. () (\d+)
  89. )/x;
  90. my $obj_re =
  91. qr/(?: \{ \s* (?: ${objcomponent_re} \s+ )* ${objcomponent_re} \s* \} )/x;
  92. my $xmlobj_re =
  93. qr/(?: (?: ${xmlobjcomponent_re} \. )* ${xmlobjcomponent_re} )/x;
  94. ######## NAME TO OID REPOSITORY
  95. # Recorded OIDs, to support things like '{ pkcs1 1 }'
  96. # Do note that we don't currently support relative OIDs
  97. #
  98. # The key is the identifier.
  99. #
  100. # The value is a hash, composed of:
  101. # type => 'arc' | 'leaf'
  102. # nums => [ LIST ]
  103. # Note that the |type| always starts as a 'leaf', and may change to an 'arc'
  104. # on the fly, as new OIDs are parsed.
  105. my %name2oid = ();
  106. ########
  107. =head1 SUBROUTINES/METHODS
  108. =over 4
  109. =item parse_oid()
  110. TBA
  111. =cut
  112. sub parse_oid {
  113. my $input = shift;
  114. croak "Invalid extra arguments" if (@_);
  115. # The components become a list of ( identifier, number ) pairs,
  116. # where they can also be the empty string if they are not present
  117. # in the input.
  118. my @components;
  119. if ($input =~ m/^\s*(${obj_re})\s*$/x) {
  120. my $oid = $1;
  121. @components = ( $oid =~ m/${objcomponent_re}\s*/g );
  122. } elsif ($input =~ m/^\s*(${xmlobj_re})\s*$/) {
  123. my $oid = $1;
  124. @components = ( $oid =~ m/${xmlobjcomponent_re}\.?/g );
  125. }
  126. croak "Invalid ASN.1 object '$input'" unless @components;
  127. die "Internal error when parsing '$input'"
  128. unless scalar(@components) % 2 == 0;
  129. # As we currently only support a name without number as first
  130. # component, the easiest is to have a direct look at it and
  131. # hack it.
  132. my @first = _pairmap {
  133. my ($a, $b) = @$_;
  134. return $b if $b ne '';
  135. return @{$name2oid{$a}->{nums}} if $a ne '' && defined $name2oid{$a};
  136. croak "Undefined identifier $a" if $a ne '';
  137. croak "Empty OID element (how's that possible?)";
  138. } ( @components[0..1] );
  139. my @numbers =
  140. (
  141. @first,
  142. _pairmap {
  143. my ($a, $b) = @$_;
  144. return $b if $b ne '';
  145. croak "Unsupported relative OID $a" if $a ne '';
  146. croak "Empty OID element (how's that possible?)";
  147. } @components[2..$#components]
  148. );
  149. # If the first component has an identifier and there are other
  150. # components following it, we change the type of that identifier
  151. # to 'arc'.
  152. if (scalar @components > 2
  153. && $components[0] ne ''
  154. && defined $name2oid{$components[0]}) {
  155. $name2oid{$components[0]}->{type} = 'arc';
  156. }
  157. return @numbers;
  158. }
  159. =item encode_oid()
  160. =cut
  161. # Forward declaration
  162. sub encode_oid_nums;
  163. sub encode_oid {
  164. return encode_oid_nums parse_oid @_;
  165. }
  166. =item register_oid()
  167. =cut
  168. sub register_oid {
  169. my $name = shift;
  170. my @nums = parse_oid @_;
  171. if (defined $name2oid{$name}) {
  172. my $str1 = join(',', @nums);
  173. my $str2 = join(',', @{$name2oid{$name}->{nums}});
  174. croak "Invalid redefinition of $name with different value"
  175. unless $str1 eq $str2;
  176. } else {
  177. $name2oid{$name} = { type => 'leaf', nums => [ @nums ] };
  178. }
  179. }
  180. =item registered_oid_arcs()
  181. =item registered_oid_leaves()
  182. =cut
  183. sub _registered_oids {
  184. my $type = shift;
  185. return grep { $name2oid{$_}->{type} eq $type } keys %name2oid;
  186. }
  187. sub registered_oid_arcs {
  188. return _registered_oids( 'arc' );
  189. }
  190. sub registered_oid_leaves {
  191. return _registered_oids( 'leaf' );
  192. }
  193. =item encode_oid_nums()
  194. =cut
  195. # Internal helper. It takes a numeric OID component and generates the
  196. # DER encoding for it.
  197. sub _gen_oid_bytes {
  198. my $num = shift;
  199. my $cnt = 0;
  200. return ( $num ) if $num < 128;
  201. return ( ( map { $_ | 0x80 } _gen_oid_bytes($num >> 7) ), $num & 0x7f );
  202. }
  203. sub encode_oid_nums {
  204. my @numbers = @_;
  205. croak 'Invalid OID values: ( ', join(', ', @numbers), ' )'
  206. if (scalar @numbers < 2
  207. || $numbers[0] < 0 || $numbers[0] > 2
  208. || $numbers[1] < 0 || $numbers[1] > 39);
  209. my $first = shift(@numbers) * 40 + shift(@numbers);
  210. @numbers = ( $first, map { _gen_oid_bytes($_) } @numbers );
  211. return @numbers;
  212. }
  213. =back
  214. =head1 AUTHOR
  215. Richard levitte, C<< <richard at levitte.org> >>
  216. =cut
  217. ######## Helpers
  218. sub _pairs (@) {
  219. croak "Odd number of arguments" if @_ & 1;
  220. my @pairlist = ();
  221. while (@_) {
  222. my $x = [ shift, shift ];
  223. push @pairlist, $x;
  224. }
  225. return @pairlist;
  226. }
  227. sub _pairmap (&@) {
  228. my $block = shift;
  229. map { $block->($_) } _pairs @_;
  230. }
  231. 1; # End of OpenSSL::OID