#! /usr/bin/env perl
# Copyright 2018-2021 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
package OpenSSL::Util;
use strict;
use warnings;
use Carp;
use Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
$VERSION = "0.1";
@ISA = qw(Exporter);
@EXPORT = qw(cmp_versions quotify1 quotify_l fixup_cmd_elements fixup_cmd
dump_data);
@EXPORT_OK = qw();
=head1 NAME
OpenSSL::Util - small OpenSSL utilities
=head1 SYNOPSIS
use OpenSSL::Util;
$versiondiff = cmp_versions('1.0.2k', '3.0.1');
# $versiondiff should be -1
$versiondiff = cmp_versions('1.1.0', '1.0.2a');
# $versiondiff should be 1
$versiondiff = cmp_versions('1.1.1', '1.1.1');
# $versiondiff should be 0
=head1 DESCRIPTION
=over
=item B<cmp_versions "VERSION1", "VERSION2">
Compares VERSION1 with VERSION2, paying attention to OpenSSL versioning.
Returns 1 if VERSION1 is greater than VERSION2, 0 if they are equal, and
-1 if VERSION1 is less than VERSION2.
=back
=cut
# Until we're rid of everything with the old version scheme,
# we need to be able to handle older style x.y.zl versions.
# In terms of comparison, the x.y.zl and the x.y.z schemes
# are compatible... mostly because the latter starts at a
# new major release with a new major number.
sub _ossl_versionsplit {
my $textversion = shift;
return $textversion if $textversion eq '*';
my ($major,$minor,$edit,$letter) =
$textversion =~ /^(\d+)\.(\d+)\.(\d+)([a-z]{0,2})$/;
return ($major,$minor,$edit,$letter);
}
sub cmp_versions {
my @a_split = _ossl_versionsplit(shift);
my @b_split = _ossl_versionsplit(shift);
my $verdict = 0;
while (@a_split) {
# The last part is a letter sequence (or a '*')
if (scalar @a_split == 1) {
$verdict = $a_split[0] cmp $b_split[0];
} else {
$verdict = $a_split[0] <=> $b_split[0];
}
shift @a_split;
shift @b_split;
last unless $verdict == 0;
}
return $verdict;
}
# It might be practical to quotify some strings and have them protected
# from possible harm. These functions primarily quote things that might
# be interpreted wrongly by a perl eval.
=over 4
=item quotify1 STRING
This adds quotes (") around the given string, and escapes any $, @, \,
" and ' by prepending a \ to them.
=back
=cut
sub quotify1 {
my $s = shift @_;
$s =~ s/([\$\@\\"'])/\\$1/g;
'"'.$s.'"';
}
=over 4
=item quotify_l LIST
For each defined element in LIST (i.e. elements that aren't undef), have
it quotified with 'quotify1'.
Undefined elements are ignored.
=cut
sub quotify_l {
map {
if (!defined($_)) {
();
} else {
quotify1($_);
}
} @_;
}
=over 4
=item fixup_cmd_elements LIST
Fixes up the command line elements given by LIST in a platform specific
manner.
The result of this function is a copy of LIST with strings where quotes and
escapes have been injected as necessary depending on the content of each
LIST string.
This can also be used to put quotes around the executable of a command.
I<This must never ever be done on VMS.>
=back
=cut
sub fixup_cmd_elements {
# A formatter for the command arguments, defaulting to the Unix setup
my $arg_formatter =
sub { $_ = shift;
($_ eq '' || /\s|[\{\}\\\$\[\]\*\?\|\&:;<>]/) ? "'$_'" : $_ };
if ( $^O eq "VMS") { # VMS setup
$arg_formatter = sub {
$_ = shift;
if ($_ eq '' || /\s|[!"[:upper:]]/) {
s/"/""/g;
'"'.$_.'"';
} else {
$_;
}
};
} elsif ( $^O eq "MSWin32") { # MSWin setup
$arg_formatter = sub {
$_ = shift;
if ($_ eq '' || /\s|["\|\&\*\;<>]/) {
s/(["\\])/\\$1/g;
'"'.$_.'"';
} else {
$_;
}
};
}
return ( map { $arg_formatter->($_) } @_ );
}
=over 4
=item fixup_cmd LIST
This is a sibling of fixup_cmd_elements() that expects the LIST to be a
complete command line. It does the same thing as fixup_cmd_elements(),
expect that it treats the first LIST element specially on VMS.
=back
=cut
sub fixup_cmd {
return fixup_cmd_elements(@_) unless $^O eq 'VMS';
# The rest is VMS specific
my $prog = shift;
# On VMS, running random executables without having a command symbol
# means running them with the MCR command. This is an old PDP-11
# command that stuck around.
# This assumes that we're passed the name of an executable. This is a
# safe assumption for OpenSSL command lines
my $prefix = 'MCR';
if ($prog =~ /^MCR$/i) {
# If the first element is "MCR" (independent of case) already, then
# we assume that the program it runs is already written the way it
# should, and just grab it.
$prog = shift;
} else {
# If the command itself doesn't have a directory spec, make sure
# that there is one. Otherwise, MCR assumes that the program
# resides in SYS$SYSTEM:
$prog = '[]' . $prog unless $prog =~ /^(?:[\$a-z0-9_]+:)?[<\[]/i;
}
return ( $prefix, $prog, fixup_cmd_elements(@_) );
}
=item dump_data REF, OPTS
Dump the data from REF into a string that can be evaluated into the same
data by Perl.
OPTS is the rest of the arguments, expected to be pairs formed with C<< => >>.
The following OPTS keywords are understood:
=over 4
=item B<delimiters =E<gt> 0 | 1>
Include the outer delimiter of the REF type in the resulting string if C<1>,
otherwise not.
=item B<indent =E<gt> num>
The indentation of the caller, i.e. an initial value. If not given, there
will be no indentation at all, and the string will only be one line.
=back
=cut
sub dump_data {
my $ref = shift;
# Available options:
# indent => callers indentation ( undef for no indentation,
# an integer otherwise )
# delimiters => 1 if outer delimiters should be added
my %opts = @_;
my $indent = $opts{indent} // 1;
# Indentation of the whole structure, where applicable
my $nlindent1 = defined $opts{indent} ? "\n" . ' ' x $indent : ' ';
# Indentation of individual items, where applicable
my $nlindent2 = defined $opts{indent} ? "\n" . ' ' x ($indent + 4) : ' ';
my %subopts = ();
$subopts{delimiters} = 1;
$subopts{indent} = $opts{indent} + 4 if defined $opts{indent};
my $product; # Finished product, or reference to a function that
# produces a string, given $_
# The following are only used when $product is a function reference
my $delim_l; # Left delimiter of structure
my $delim_r; # Right delimiter of structure
my $separator; # Item separator
my @items; # Items to iterate over
if (ref($ref) eq "ARRAY") {
if (scalar @$ref == 0) {
$product = $opts{delimiters} ? '[]' : '';
} else {
$product = sub {
dump_data(\$_, %subopts)
};
$delim_l = ($opts{delimiters} ? '[' : '').$nlindent2;
$delim_r = $nlindent1.($opts{delimiters} ? ']' : '');
$separator = ",$nlindent2";
@items = @$ref;
}
} elsif (ref($ref) eq "HASH") {
if (scalar keys %$ref == 0) {
$product = $opts{delimiters} ? '{}' : '';
} else {
$product = sub {
quotify1($_) . " => " . dump_data($ref->{$_}, %subopts);
};
$delim_l = ($opts{delimiters} ? '{' : '').$nlindent2;
$delim_r = $nlindent1.($opts{delimiters} ? '}' : '');
$separator = ",$nlindent2";
@items = sort keys %$ref;
}
} elsif (ref($ref) eq "SCALAR") {
$product = defined $$ref ? quotify1 $$ref : "undef";
} else {
$product = defined $ref ? quotify1 $ref : "undef";
}
if (ref($product) eq "CODE") {
$delim_l . join($separator, map { &$product } @items) . $delim_r;
} else {
$product;
}
}
=back
=cut
1;