util/perl/OpenSSL/Util.pm

   1 #! /usr/bin/env perl
   2 # Copyright 2018-2021 The OpenSSL Project Authors. All Rights Reserved.
   3 #
   4 # Licensed under the Apache License 2.0 (the "License").  You may not use
   5 # this file except in compliance with the License.  You can obtain a copy
   6 # in the file LICENSE in the source distribution or at
   7 # https://www.openssl.org/source/license.html
   8
   9 package OpenSSL::Util;
  10
  11 use strict;
  12 use warnings;
  13 use Carp;
  14
  15 use Exporter;
  16 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  17 $VERSION = "0.1";
  18 @ISA = qw(Exporter);
  19 @EXPORT = qw(cmp_versions quotify1 quotify_l fixup_cmd_elements fixup_cmd
  20              dump_data);
  21 @EXPORT_OK = qw();
  22
  23 =head1 NAME
  24
  25 OpenSSL::Util - small OpenSSL utilities
  26
  27 =head1 SYNOPSIS
  28
  29   use OpenSSL::Util;
  30
  31   $versiondiff = cmp_versions('1.0.2k', '3.0.1');
  32   # $versiondiff should be -1
  33
  34   $versiondiff = cmp_versions('1.1.0', '1.0.2a');
  35   # $versiondiff should be 1
  36
  37   $versiondiff = cmp_versions('1.1.1', '1.1.1');
  38   # $versiondiff should be 0
  39
  40 =head1 DESCRIPTION
  41
  42 =over
  43
  44 =item B<cmp_versions "VERSION1", "VERSION2">
  45
  46 Compares VERSION1 with VERSION2, paying attention to OpenSSL versioning.
  47
  48 Returns 1 if VERSION1 is greater than VERSION2, 0 if they are equal, and
  49 -1 if VERSION1 is less than VERSION2.
  50
  51 =back
  52
  53 =cut
  54
  55 # Until we're rid of everything with the old version scheme,
  56 # we need to be able to handle older style x.y.zl versions.
  57 # In terms of comparison, the x.y.zl and the x.y.z schemes
  58 # are compatible...  mostly because the latter starts at a
  59 # new major release with a new major number.
  60 sub _ossl_versionsplit {
  61     my $textversion = shift;
  62     return $textversion if $textversion eq '*';
  63     my ($major,$minor,$edit,$letter) =
  64         $textversion =~ /^(\d+)\.(\d+)\.(\d+)([a-z]{0,2})$/;
  65
  66     return ($major,$minor,$edit,$letter);
  67 }
  68
  69 sub cmp_versions {
  70     my @a_split = _ossl_versionsplit(shift);
  71     my @b_split = _ossl_versionsplit(shift);
  72     my $verdict = 0;
  73
  74     while (@a_split) {
  75         # The last part is a letter sequence (or a '*')
  76         if (scalar @a_split == 1) {
  77             $verdict = $a_split[0] cmp $b_split[0];
  78         } else {
  79             $verdict = $a_split[0] <=> $b_split[0];
  80         }
  81         shift @a_split;
  82         shift @b_split;
  83         last unless $verdict == 0;
  84     }
  85
  86     return $verdict;
  87 }
  88
  89 # It might be practical to quotify some strings and have them protected
  90 # from possible harm.  These functions primarily quote things that might
  91 # be interpreted wrongly by a perl eval.
  92
  93 =over 4
  94
  95 =item quotify1 STRING
  96
  97 This adds quotes (") around the given string, and escapes any $, @, \,
  98 " and ' by prepending a \ to them.
  99
 100 =back
 101
 102 =cut
 103
 104 sub quotify1 {
 105     my $s = shift @_;
 106     $s =~ s/([\$\@\\"'])/\\$1/g;
 107     '"'.$s.'"';
 108 }
 109
 110 =over 4
 111
 112 =item quotify_l LIST
 113
 114 For each defined element in LIST (i.e. elements that aren't undef), have
 115 it quotified with 'quotify1'.
 116 Undefined elements are ignored.
 117
 118 =cut
 119
 120 sub quotify_l {
 121     map {
 122         if (!defined($_)) {
 123             ();
 124         } else {
 125             quotify1($_);
 126         }
 127     } @_;
 128 }
 129
 130 =over 4
 131
 132 =item fixup_cmd_elements LIST
 133
 134 Fixes up the command line elements given by LIST in a platform specific
 135 manner.
 136
 137 The result of this function is a copy of LIST with strings where quotes and
 138 escapes have been injected as necessary depending on the content of each
 139 LIST string.
 140
 141 This can also be used to put quotes around the executable of a command.
 142 I<This must never ever be done on VMS.>
 143
 144 =back
 145
 146 =cut
 147
 148 sub fixup_cmd_elements {
 149     # A formatter for the command arguments, defaulting to the Unix setup
 150     my $arg_formatter =
 151         sub { $_ = shift;
 152               ($_ eq '' || /\s|[\{\}\\\$\[\]\*\?\|\&:;<>]/) ? "'$_'" : $_ };
 153
 154     if ( $^O eq "VMS") {        # VMS setup
 155         $arg_formatter = sub {
 156             $_ = shift;
 157             if ($_ eq '' || /\s|[!"[:upper:]]/) {
 158                 s/"/""/g;
 159                 '"'.$_.'"';
 160             } else {
 161                 $_;
 162             }
 163         };
 164     } elsif ( $^O eq "MSWin32") { # MSWin setup
 165         $arg_formatter = sub {
 166             $_ = shift;
 167             if ($_ eq '' || /\s|["\|\&\*\;<>]/) {
 168                 s/(["\\])/\\$1/g;
 169                 '"'.$_.'"';
 170             } else {
 171                 $_;
 172             }
 173         };
 174     }
 175
 176     return ( map { $arg_formatter->($_) } @_ );
 177 }
 178
 179 =over 4
 180
 181 =item fixup_cmd LIST
 182
 183 This is a sibling of fixup_cmd_elements() that expects the LIST to be a
 184 complete command line.  It does the same thing as fixup_cmd_elements(),
 185 expect that it treats the first LIST element specially on VMS.
 186
 187 =back
 188
 189 =cut
 190
 191 sub fixup_cmd {
 192     return fixup_cmd_elements(@_) unless $^O eq 'VMS';
 193
 194     # The rest is VMS specific
 195     my $cmd = shift;
 196
 197     # Prefix to be applied as needed.  Essentially, we need to determine
 198     # if the command is an executable file (something.EXE), and invoke it
 199     # with the MCR command in that case.  MCR is an old PDP-11 command that
 200     # stuck around.
 201     my @prefix;
 202
 203     if ($cmd =~ m|^\@|) {
 204         # The command is an invocation of a command procedure (also known as
 205         # "script"), no modification needed.
 206         @prefix = ();
 207     } elsif ($cmd =~ m|^MCR$|) {
 208         # The command is MCR, so there's nothing much to do apart from
 209         # making sure that the file name following it isn't treated with
 210         # fixup_cmd_elements(), 'cause MCR doesn't like strings.
 211         @prefix = ( $cmd );
 212         $cmd = shift;
 213     } else {
 214         # All that's left now is to check whether the command is an executable
 215         # file, and if it's not, simply assume that it is a DCL command.
 216
 217         # Make sure we have a proper file name, i.e. add the default
 218         # extension '.exe' if there isn't one already.
 219         my $executable = ($cmd =~ m|.[a-z0-9\$]*$|) ? $cmd : $cmd . '.exe';
 220         if (-e $executable) {
 221             # It seems to be an executable, so we make sure to prefix it
 222             # with MCR, for proper invocation.  We also make sure that
 223             # there's a directory specification, or otherwise, MCR will
 224             # assume that the executable is in SYS$SYSTEM:
 225             @prefix = ( 'MCR' );
 226             $cmd = '[]' . $cmd unless $cmd =~ /^(?:[\$a-z0-9_]+:)?[<\[]/i;
 227         } else {
 228             # If it isn't an executable, then we assume that it's a DCL
 229             # command, and do no further processing, apart from argument
 230             # fixup.
 231             @prefix = ();
 232         }
 233     }
 234
 235     return ( @prefix, $cmd, fixup_cmd_elements(@_) );
 236 }
 237
 238 =item dump_data REF, OPTS
 239
 240 Dump the data from REF into a string that can be evaluated into the same
 241 data by Perl.
 242
 243 OPTS is the rest of the arguments, expected to be pairs formed with C<< => >>.
 244 The following OPTS keywords are understood:
 245
 246 =over 4
 247
 248 =item B<delimiters =E<gt> 0 | 1>
 249
 250 Include the outer delimiter of the REF type in the resulting string if C<1>,
 251 otherwise not.
 252
 253 =item B<indent =E<gt> num>
 254
 255 The indentation of the caller, i.e. an initial value.  If not given, there
 256 will be no indentation at all, and the string will only be one line.
 257
 258 =back
 259
 260 =cut
 261
 262 sub dump_data {
 263     my $ref = shift;
 264     # Available options:
 265     # indent           => callers indentation ( undef for no indentation,
 266     #                     an integer otherwise )
 267     # delimiters       => 1 if outer delimiters should be added
 268     my %opts = @_;
 269
 270     my $indent = $opts{indent} // 1;
 271     # Indentation of the whole structure, where applicable
 272     my $nlindent1 = defined $opts{indent} ? "\n" . ' ' x $indent : ' ';
 273     # Indentation of individual items, where applicable
 274     my $nlindent2 = defined $opts{indent} ? "\n" . ' ' x ($indent + 4) : ' ';
 275     my %subopts = ();
 276
 277     $subopts{delimiters} = 1;
 278     $subopts{indent} = $opts{indent} + 4 if defined $opts{indent};
 279
 280     my $product;      # Finished product, or reference to a function that
 281                       # produces a string, given $_
 282     # The following are only used when $product is a function reference
 283     my $delim_l;      # Left delimiter of structure
 284     my $delim_r;      # Right delimiter of structure
 285     my $separator;    # Item separator
 286     my @items;        # Items to iterate over
 287
 288      if (ref($ref) eq "ARRAY") {
 289          if (scalar @$ref == 0) {
 290              $product = $opts{delimiters} ? '[]' : '';
 291          } else {
 292              $product = sub {
 293                  dump_data(\$_, %subopts)
 294              };
 295              $delim_l = ($opts{delimiters} ? '[' : '').$nlindent2;
 296              $delim_r = $nlindent1.($opts{delimiters} ? ']' : '');
 297              $separator = ",$nlindent2";
 298              @items = @$ref;
 299          }
 300      } elsif (ref($ref) eq "HASH") {
 301          if (scalar keys %$ref == 0) {
 302              $product = $opts{delimiters} ? '{}' : '';
 303          } else {
 304              $product = sub {
 305                  quotify1($_) . " => " . dump_data($ref->{$_}, %subopts);
 306              };
 307              $delim_l = ($opts{delimiters} ? '{' : '').$nlindent2;
 308              $delim_r = $nlindent1.($opts{delimiters} ? '}' : '');
 309              $separator = ",$nlindent2";
 310              @items = sort keys %$ref;
 311          }
 312      } elsif (ref($ref) eq "SCALAR") {
 313          $product = defined $$ref ? quotify1 $$ref : "undef";
 314      } else {
 315          $product = defined $ref ? quotify1 $ref : "undef";
 316      }
 317
 318      if (ref($product) eq "CODE") {
 319          $delim_l . join($separator, map { &$product } @items) . $delim_r;
 320      } else {
 321          $product;
 322      }
 323 }
 324
 325 =back
 326
 327 =cut
 328
 329 1;