mirror of https://github.com/openssl/openssl.git
308 lines
7.6 KiB
Perl
308 lines
7.6 KiB
Perl
# Copyright 2016-2020 The OpenSSL Project Authors. All Rights Reserved.
|
|
#
|
|
# Licensed under the Apache License 2.0 (the "License"). You may not use
|
|
# this file except in compliance with the License. You can obtain a copy
|
|
# in the file LICENSE in the source distribution or at
|
|
# https://www.openssl.org/source/license.html
|
|
|
|
# Author note: this is originally RL::ASN1::OID,
|
|
# repurposed by the author for OpenSSL use.
|
|
|
|
package OpenSSL::OID;
|
|
|
|
use 5.10.0;
|
|
use strict;
|
|
use warnings;
|
|
use Carp;
|
|
|
|
use Exporter;
|
|
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
|
|
@ISA = qw(Exporter);
|
|
@EXPORT = qw(parse_oid encode_oid register_oid
|
|
registered_oid_arcs registered_oid_leaves);
|
|
@EXPORT_OK = qw(encode_oid_nums);
|
|
|
|
# Unfortunately, the pairwise List::Util functionality came with perl
|
|
# v5.19.3, and I want to target absolute compatibility with perl 5.10
|
|
# and up. That means I have to implement quick pairwise functions here.
|
|
|
|
#use List::Util;
|
|
sub _pairs (@);
|
|
sub _pairmap (&@);
|
|
|
|
=head1 NAME
|
|
|
|
OpenSSL::OID - an OBJECT IDENTIFIER parser / encoder
|
|
|
|
=head1 VERSION
|
|
|
|
Version 0.1
|
|
|
|
=cut
|
|
|
|
our $VERSION = '0.1';
|
|
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use OpenSSL::OID;
|
|
|
|
# This gives the array ( 1 2 840 113549 1 1 )
|
|
my @nums = parse_oid('{ pkcs-1 1 }');
|
|
|
|
# This gives the array of DER encoded bytes for the OID, i.e.
|
|
# ( 42, 134, 72, 134, 247, 13, 1, 1 )
|
|
my @bytes = encode_oid('{ pkcs-1 1 }');
|
|
|
|
# This registers a name with an OID. It's saved internally and
|
|
# serves as repository of names for further parsing, such as 'pkcs-1'
|
|
# in the strings used above.
|
|
register_object('pkcs-1', '{ pkcs 1 }');
|
|
|
|
|
|
use OpenSSL::OID qw(:DEFAULT encode_oid_nums);
|
|
|
|
# This does the same as encode_oid(), but takes the output of
|
|
# parse_oid() as input.
|
|
my @bytes = encode_oid_nums(@nums);
|
|
|
|
=head1 EXPORT
|
|
|
|
The functions parse_oid and encode_oid are exported by default.
|
|
The function encode_oid_nums() can be exported explicitly.
|
|
|
|
=cut
|
|
|
|
######## REGEXPS
|
|
|
|
# ASN.1 object identifiers come in two forms: 1) the bracketed form
|
|
#(referred to as ObjectIdentifierValue in X.690), 2) the dotted form
|
|
#(referred to as XMLObjIdentifierValue in X.690)
|
|
#
|
|
# examples of 1 (these are all the OID for rsaEncrypted):
|
|
#
|
|
# { iso (1) 2 840 11349 1 1 }
|
|
# { pkcs 1 1 }
|
|
# { pkcs1 1 }
|
|
#
|
|
# examples of 2:
|
|
#
|
|
# 1.2.840.113549.1.1
|
|
# pkcs.1.1
|
|
# pkcs1.1
|
|
#
|
|
my $identifier_re = qr/[a-z](?:[-_A-Za-z0-9]*[A-Za-z0-9])?/;
|
|
# The only difference between $objcomponent_re and $xmlobjcomponent_re is
|
|
# the separator in the top branch. Each component is always parsed in two
|
|
# groups, so we get a pair of values regardless. That's the reason for the
|
|
# empty parentheses.
|
|
# Because perl doesn't try to do an exhaustive try of every branch it rather
|
|
# stops on the first that matches, we need to have them in order of longest
|
|
# to shortest where there may be ambiguity.
|
|
my $objcomponent_re = qr/(?|
|
|
(${identifier_re}) \s* \((\d+)\)
|
|
|
|
|
(${identifier_re}) ()
|
|
|
|
|
()(\d+)
|
|
)/x;
|
|
my $xmlobjcomponent_re = qr/(?|
|
|
(${identifier_re}) \. \((\d+)\)
|
|
|
|
|
(${identifier_re}) ()
|
|
|
|
|
() (\d+)
|
|
)/x;
|
|
|
|
my $obj_re =
|
|
qr/(?: \{ \s* (?: ${objcomponent_re} \s+ )* ${objcomponent_re} \s* \} )/x;
|
|
my $xmlobj_re =
|
|
qr/(?: (?: ${xmlobjcomponent_re} \. )* ${xmlobjcomponent_re} )/x;
|
|
|
|
######## NAME TO OID REPOSITORY
|
|
|
|
# Recorded OIDs, to support things like '{ pkcs1 1 }'
|
|
# Do note that we don't currently support relative OIDs
|
|
#
|
|
# The key is the identifier.
|
|
#
|
|
# The value is a hash, composed of:
|
|
# type => 'arc' | 'leaf'
|
|
# nums => [ LIST ]
|
|
# Note that the |type| always starts as a 'leaf', and may change to an 'arc'
|
|
# on the fly, as new OIDs are parsed.
|
|
my %name2oid = ();
|
|
|
|
########
|
|
|
|
=head1 SUBROUTINES/METHODS
|
|
|
|
=over 4
|
|
|
|
=item parse_oid()
|
|
|
|
TBA
|
|
|
|
=cut
|
|
|
|
sub parse_oid {
|
|
my $input = shift;
|
|
|
|
croak "Invalid extra arguments" if (@_);
|
|
|
|
# The components become a list of ( identifier, number ) pairs,
|
|
# where they can also be the empty string if they are not present
|
|
# in the input.
|
|
my @components;
|
|
if ($input =~ m/^\s*(${obj_re})\s*$/x) {
|
|
my $oid = $1;
|
|
@components = ( $oid =~ m/${objcomponent_re}\s*/g );
|
|
} elsif ($input =~ m/^\s*(${xmlobj_re})\s*$/) {
|
|
my $oid = $1;
|
|
@components = ( $oid =~ m/${xmlobjcomponent_re}\.?/g );
|
|
}
|
|
|
|
croak "Invalid ASN.1 object '$input'" unless @components;
|
|
die "Internal error when parsing '$input'"
|
|
unless scalar(@components) % 2 == 0;
|
|
|
|
# As we currently only support a name without number as first
|
|
# component, the easiest is to have a direct look at it and
|
|
# hack it.
|
|
my @first = _pairmap {
|
|
my ($a, $b) = @$_;
|
|
return $b if $b ne '';
|
|
return @{$name2oid{$a}->{nums}} if $a ne '' && defined $name2oid{$a};
|
|
croak "Undefined identifier $a" if $a ne '';
|
|
croak "Empty OID element (how's that possible?)";
|
|
} ( @components[0..1] );
|
|
|
|
my @numbers =
|
|
(
|
|
@first,
|
|
_pairmap {
|
|
my ($a, $b) = @$_;
|
|
return $b if $b ne '';
|
|
croak "Unsupported relative OID $a" if $a ne '';
|
|
croak "Empty OID element (how's that possible?)";
|
|
} @components[2..$#components]
|
|
);
|
|
|
|
# If the first component has an identifier and there are other
|
|
# components following it, we change the type of that identifier
|
|
# to 'arc'.
|
|
if (scalar @components > 2
|
|
&& $components[0] ne ''
|
|
&& defined $name2oid{$components[0]}) {
|
|
$name2oid{$components[0]}->{type} = 'arc';
|
|
}
|
|
|
|
return @numbers;
|
|
}
|
|
|
|
=item encode_oid()
|
|
|
|
=cut
|
|
|
|
# Forward declaration
|
|
sub encode_oid_nums;
|
|
sub encode_oid {
|
|
return encode_oid_nums parse_oid @_;
|
|
}
|
|
|
|
=item register_oid()
|
|
|
|
=cut
|
|
|
|
sub register_oid {
|
|
my $name = shift;
|
|
my @nums = parse_oid @_;
|
|
|
|
if (defined $name2oid{$name}) {
|
|
my $str1 = join(',', @nums);
|
|
my $str2 = join(',', @{$name2oid{$name}->{nums}});
|
|
|
|
croak "Invalid redefinition of $name with different value"
|
|
unless $str1 eq $str2;
|
|
} else {
|
|
$name2oid{$name} = { type => 'leaf', nums => [ @nums ] };
|
|
}
|
|
}
|
|
|
|
=item registered_oid_arcs()
|
|
|
|
=item registered_oid_leaves()
|
|
|
|
=cut
|
|
|
|
sub _registered_oids {
|
|
my $type = shift;
|
|
|
|
return grep { $name2oid{$_}->{type} eq $type } keys %name2oid;
|
|
}
|
|
|
|
sub registered_oid_arcs {
|
|
return _registered_oids( 'arc' );
|
|
}
|
|
|
|
sub registered_oid_leaves {
|
|
return _registered_oids( 'leaf' );
|
|
}
|
|
|
|
=item encode_oid_nums()
|
|
|
|
=cut
|
|
|
|
# Internal helper. It takes a numeric OID component and generates the
|
|
# DER encoding for it.
|
|
sub _gen_oid_bytes {
|
|
my $num = shift;
|
|
my $cnt = 0;
|
|
|
|
return ( $num ) if $num < 128;
|
|
return ( ( map { $_ | 0x80 } _gen_oid_bytes($num >> 7) ), $num & 0x7f );
|
|
}
|
|
|
|
sub encode_oid_nums {
|
|
my @numbers = @_;
|
|
|
|
croak 'Invalid OID values: ( ', join(', ', @numbers), ' )'
|
|
if (scalar @numbers < 2
|
|
|| $numbers[0] < 0 || $numbers[0] > 2
|
|
|| $numbers[1] < 0 || $numbers[1] > 39);
|
|
|
|
my $first = shift(@numbers) * 40 + shift(@numbers);
|
|
@numbers = ( $first, map { _gen_oid_bytes($_) } @numbers );
|
|
|
|
return @numbers;
|
|
}
|
|
|
|
=back
|
|
|
|
=head1 AUTHOR
|
|
|
|
Richard levitte, C<< <richard at levitte.org> >>
|
|
|
|
=cut
|
|
|
|
######## Helpers
|
|
|
|
sub _pairs (@) {
|
|
croak "Odd number of arguments" if @_ & 1;
|
|
|
|
my @pairlist = ();
|
|
|
|
while (@_) {
|
|
my $x = [ shift, shift ];
|
|
push @pairlist, $x;
|
|
}
|
|
return @pairlist;
|
|
}
|
|
|
|
sub _pairmap (&@) {
|
|
my $block = shift;
|
|
map { $block->($_) } _pairs @_;
|
|
}
|
|
|
|
1; # End of OpenSSL::OID
|