Util.pm 9.1 KB

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