source: vbox/trunk/src/libs/openssl-3.0.7/util/perl/OpenSSL/Util.pm@ 99507

#! /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;