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 9package OpenSSL::Util; 10 11use strict; 12use warnings; 13use Carp; 14 15use Exporter; 16use 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 25OpenSSL::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 46Compares VERSION1 with VERSION2, paying attention to OpenSSL versioning. 47 48Returns 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. 60sub _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 69sub 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 97This adds quotes (") around the given string, and escapes any $, @, \, 98" and ' by prepending a \ to them. 99 100=back 101 102=cut 103 104sub quotify1 { 105 my $s = shift @_; 106 $s =~ s/([\$\@\\"'])/\\$1/g; 107 '"'.$s.'"'; 108} 109 110=over 4 111 112=item quotify_l LIST 113 114For each defined element in LIST (i.e. elements that aren't undef), have 115it quotified with 'quotify1'. 116Undefined elements are ignored. 117 118=cut 119 120sub 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 134Fixes up the command line elements given by LIST in a platform specific 135manner. 136 137The result of this function is a copy of LIST with strings where quotes and 138escapes have been injected as necessary depending on the content of each 139LIST string. 140 141This can also be used to put quotes around the executable of a command. 142I<This must never ever be done on VMS.> 143 144=back 145 146=cut 147 148sub 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 183This is a sibling of fixup_cmd_elements() that expects the LIST to be a 184complete command line. It does the same thing as fixup_cmd_elements(), 185expect that it treats the first LIST element specially on VMS. 186 187=back 188 189=cut 190 191sub fixup_cmd { 192 return fixup_cmd_elements(@_) unless $^O eq 'VMS'; 193 194 # The rest is VMS specific 195 my $prog = shift; 196 197 # On VMS, running random executables without having a command symbol 198 # means running them with the MCR command. This is an old PDP-11 199 # command that stuck around. 200 # This assumes that we're passed the name of an executable. This is a 201 # safe assumption for OpenSSL command lines 202 my $prefix = 'MCR'; 203 204 if ($prog =~ /^MCR$/i) { 205 # If the first element is "MCR" (independent of case) already, then 206 # we assume that the program it runs is already written the way it 207 # should, and just grab it. 208 $prog = shift; 209 } else { 210 # If the command itself doesn't have a directory spec, make sure 211 # that there is one. Otherwise, MCR assumes that the program 212 # resides in SYS$SYSTEM: 213 $prog = '[]' . $prog unless $prog =~ /^(?:[\$a-z0-9_]+:)?[<\[]/i; 214 } 215 216 return ( $prefix, $prog, fixup_cmd_elements(@_) ); 217} 218 219=item dump_data REF, OPTS 220 221Dump the data from REF into a string that can be evaluated into the same 222data by Perl. 223 224OPTS is the rest of the arguments, expected to be pairs formed with C<< => >>. 225The following OPTS keywords are understood: 226 227=over 4 228 229=item B<delimiters =E<gt> 0 | 1> 230 231Include the outer delimiter of the REF type in the resulting string if C<1>, 232otherwise not. 233 234=item B<indent =E<gt> num> 235 236The indentation of the caller, i.e. an initial value. If not given, there 237will be no indentation at all, and the string will only be one line. 238 239=back 240 241=cut 242 243sub dump_data { 244 my $ref = shift; 245 # Available options: 246 # indent => callers indentation ( undef for no indentation, 247 # an integer otherwise ) 248 # delimiters => 1 if outer delimiters should be added 249 my %opts = @_; 250 251 my $indent = $opts{indent} // 1; 252 # Indentation of the whole structure, where applicable 253 my $nlindent1 = defined $opts{indent} ? "\n" . ' ' x $indent : ' '; 254 # Indentation of individual items, where applicable 255 my $nlindent2 = defined $opts{indent} ? "\n" . ' ' x ($indent + 4) : ' '; 256 my %subopts = (); 257 258 $subopts{delimiters} = 1; 259 $subopts{indent} = $opts{indent} + 4 if defined $opts{indent}; 260 261 my $product; # Finished product, or reference to a function that 262 # produces a string, given $_ 263 # The following are only used when $product is a function reference 264 my $delim_l; # Left delimiter of structure 265 my $delim_r; # Right delimiter of structure 266 my $separator; # Item separator 267 my @items; # Items to iterate over 268 269 if (ref($ref) eq "ARRAY") { 270 if (scalar @$ref == 0) { 271 $product = $opts{delimiters} ? '[]' : ''; 272 } else { 273 $product = sub { 274 dump_data(\$_, %subopts) 275 }; 276 $delim_l = ($opts{delimiters} ? '[' : '').$nlindent2; 277 $delim_r = $nlindent1.($opts{delimiters} ? ']' : ''); 278 $separator = ",$nlindent2"; 279 @items = @$ref; 280 } 281 } elsif (ref($ref) eq "HASH") { 282 if (scalar keys %$ref == 0) { 283 $product = $opts{delimiters} ? '{}' : ''; 284 } else { 285 $product = sub { 286 quotify1($_) . " => " . dump_data($ref->{$_}, %subopts); 287 }; 288 $delim_l = ($opts{delimiters} ? '{' : '').$nlindent2; 289 $delim_r = $nlindent1.($opts{delimiters} ? '}' : ''); 290 $separator = ",$nlindent2"; 291 @items = sort keys %$ref; 292 } 293 } elsif (ref($ref) eq "SCALAR") { 294 $product = defined $$ref ? quotify1 $$ref : "undef"; 295 } else { 296 $product = defined $ref ? quotify1 $ref : "undef"; 297 } 298 299 if (ref($product) eq "CODE") { 300 $delim_l . join($separator, map { &$product } @items) . $delim_r; 301 } else { 302 $product; 303 } 304} 305 306=back 307 308=cut 309 3101; 311