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 8# Author note: this is originally RL::ASN1::OID, 9# repurposed by the author for OpenSSL use. 10 11package OpenSSL::OID; 12 13use 5.10.0; 14use strict; 15use warnings; 16use Carp; 17 18use Exporter; 19use 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; 30sub _pairs (@); 31sub _pairmap (&@); 32 33=head1 NAME 34 35OpenSSL::OID - an OBJECT IDENTIFIER parser / encoder 36 37=head1 VERSION 38 39Version 0.1 40 41=cut 42 43our $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 71The functions parse_oid and encode_oid are exported by default. 72The 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# 94my $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. 102my $objcomponent_re = qr/(?| 103 (${identifier_re}) \s* \((\d+)\) 104 | 105 (${identifier_re}) () 106 | 107 ()(\d+) 108 )/x; 109my $xmlobjcomponent_re = qr/(?| 110 (${identifier_re}) \. \((\d+)\) 111 | 112 (${identifier_re}) () 113 | 114 () (\d+) 115 )/x; 116 117my $obj_re = 118 qr/(?: \{ \s* (?: ${objcomponent_re} \s+ )* ${objcomponent_re} \s* \} )/x; 119my $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. 134my %name2oid = (); 135 136######## 137 138=head1 SUBROUTINES/METHODS 139 140=over 4 141 142=item parse_oid() 143 144TBA 145 146=cut 147 148sub 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 208sub encode_oid_nums; 209sub encode_oid { 210 return encode_oid_nums parse_oid @_; 211} 212 213=item register_oid() 214 215=cut 216 217sub 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 238sub _registered_oids { 239 my $type = shift; 240 241 return grep { $name2oid{$_}->{type} eq $type } keys %name2oid; 242} 243 244sub registered_oid_arcs { 245 return _registered_oids( 'arc' ); 246} 247 248sub 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. 258sub _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 266sub 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 284Richard levitte, C<< <richard at levitte.org> >> 285 286=cut 287 288######## Helpers 289 290sub _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 302sub _pairmap (&@) { 303 my $block = shift; 304 map { $block->($_) } _pairs @_; 305} 306 3071; # End of OpenSSL::OID 308