util/perl/OpenSSL/Util.pm

   1 #! /usr/bin/env perl
   2 # Copyright 2018 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 dump_data);
  20 @EXPORT_OK = qw();
  21
  22 =head1 NAME
  23
  24 OpenSSL::Util - small OpenSSL utilities
  25
  26 =head1 SYNOPSIS
  27
  28   use OpenSSL::Util;
  29
  30   $versiondiff = cmp_versions('1.0.2k', '3.0.1');
  31   # $versiondiff should be -1
  32
  33   $versiondiff = cmp_versions('1.1.0', '1.0.2a');
  34   # $versiondiff should be 1
  35
  36   $versiondiff = cmp_versions('1.1.1', '1.1.1');
  37   # $versiondiff should be 0
  38
  39 =head1 DESCRIPTION
  40
  41 =over
  42
  43 =item B<cmp_versions "VERSION1", "VERSION2">
  44
  45 Compares VERSION1 with VERSION2, paying attention to OpenSSL versioning.
  46
  47 Returns 1 if VERSION1 is greater than VERSION2, 0 if they are equal, and
  48 -1 if VERSION1 is less than VERSION2.
  49
  50 =back
  51
  52 =cut
  53
  54 # Until we're rid of everything with the old version scheme,
  55 # we need to be able to handle older style x.y.zl versions.
  56 # In terms of comparison, the x.y.zl and the x.y.z schemes
  57 # are compatible...  mostly because the latter starts at a
  58 # new major release with a new major number.
  59 sub _ossl_versionsplit {
  60     my $textversion = shift;
  61     return $textversion if $textversion eq '*';
  62     my ($major,$minor,$edit,$letter) =
  63         $textversion =~ /^(\d+)\.(\d+)\.(\d+)([a-z]{0,2})$/;
  64
  65     return ($major,$minor,$edit,$letter);
  66 }
  67
  68 sub cmp_versions {
  69     my @a_split = _ossl_versionsplit(shift);
  70     my @b_split = _ossl_versionsplit(shift);
  71     my $verdict = 0;
  72
  73     while (@a_split) {
  74         # The last part is a letter sequence (or a '*')
  75         if (scalar @a_split == 1) {
  76             $verdict = $a_split[0] cmp $b_split[0];
  77         } else {
  78             $verdict = $a_split[0] <=> $b_split[0];
  79         }
  80         shift @a_split;
  81         shift @b_split;
  82         last unless $verdict == 0;
  83     }
  84
  85     return $verdict;
  86 }
  87
  88 # It might be practical to quotify some strings and have them protected
  89 # from possible harm.  These functions primarily quote things that might
  90 # be interpreted wrongly by a perl eval.
  91
  92 =over 4
  93
  94 =item quotify1 STRING
  95
  96 This adds quotes (") around the given string, and escapes any $, @, \,
  97 " and ' by prepending a \ to them.
  98
  99 =back
 100
 101 =cut
 102
 103 sub quotify1 {
 104     my $s = shift @_;
 105     $s =~ s/([\$\@\\"'])/\\$1/g;
 106     '"'.$s.'"';
 107 }
 108
 109 =over 4
 110
 111 =item quotify_l LIST
 112
 113 For each defined element in LIST (i.e. elements that aren't undef), have
 114 it quotified with 'quotify1'.
 115 Undefined elements are ignored.
 116
 117 =cut
 118
 119 sub quotify_l {
 120     map {
 121         if (!defined($_)) {
 122             ();
 123         } else {
 124             quotify1($_);
 125         }
 126     } @_;
 127 }
 128
 129 =item dump_data REF, OPTS
 130
 131 Dump the data from REF into a string that can be evaluated into the same
 132 data by Perl.
 133
 134 OPTS is the rest of the arguments, expected to be pairs formed with C<< => >>.
 135 The following OPTS keywords are understood:
 136
 137 =over 4
 138
 139 =item B<delimiters =E<gt> 0 | 1>
 140
 141 Include the outer delimiter of the REF type in the resulting string if C<1>,
 142 otherwise not.
 143
 144 =item B<indent =E<gt> num>
 145
 146 The indentation of the caller, i.e. an initial value.  If not given, there
 147 will be no indentation at all, and the string will only be one line.
 148
 149 =back
 150
 151 =cut
 152
 153 sub dump_data {
 154     my $ref = shift;
 155     # Available options:
 156     # indent           => callers indentation ( undef for no indentation,
 157     #                     an integer otherwise )
 158     # delimiters       => 1 if outer delimiters should be added
 159     my %opts = @_;
 160
 161     my $indent = $opts{indent} // 1;
 162     # Indentation of the whole structure, where applicable
 163     my $nlindent1 = defined $opts{indent} ? "\n" . ' ' x $indent : ' ';
 164     # Indentation of individual items, where applicable
 165     my $nlindent2 = defined $opts{indent} ? "\n" . ' ' x ($indent + 4) : ' ';
 166     my %subopts = ();
 167
 168     $subopts{delimiters} = 1;
 169     $subopts{indent} = $opts{indent} + 4 if defined $opts{indent};
 170
 171     my $product;      # Finished product, or reference to a function that
 172                       # produces a string, given $_
 173     # The following are only used when $product is a function reference
 174     my $delim_l;      # Left delimiter of structure
 175     my $delim_r;      # Right delimiter of structure
 176     my $separator;    # Item separator
 177     my @items;        # Items to iterate over
 178
 179      if (ref($ref) eq "ARRAY") {
 180          if (scalar @$ref == 0) {
 181              $product = $opts{delimiters} ? '[]' : '';
 182          } else {
 183              $product = sub {
 184                  dump_data(\$_, %subopts)
 185              };
 186              $delim_l = ($opts{delimiters} ? '[' : '').$nlindent2;
 187              $delim_r = $nlindent1.($opts{delimiters} ? ']' : '');
 188              $separator = ",$nlindent2";
 189              @items = @$ref;
 190          }
 191      } elsif (ref($ref) eq "HASH") {
 192          if (scalar keys %$ref == 0) {
 193              $product = $opts{delimiters} ? '{}' : '';
 194          } else {
 195              $product = sub {
 196                  quotify1($_) . " => " . dump_data($ref->{$_}, %subopts);
 197              };
 198              $delim_l = ($opts{delimiters} ? '{' : '').$nlindent2;
 199              $delim_r = $nlindent1.($opts{delimiters} ? '}' : '');
 200              $separator = ",$nlindent2";
 201              @items = sort keys %$ref;
 202          }
 203      } elsif (ref($ref) eq "SCALAR") {
 204          $product = defined $$ref ? quotify1 $$ref : "undef";
 205      } else {
 206          $product = defined $ref ? quotify1 $ref : "undef";
 207      }
 208
 209      if (ref($product) eq "CODE") {
 210          $delim_l . join($separator, map { &$product } @items) . $delim_r;
 211      } else {
 212          $product;
 213      }
 214 }
 215
 216 =back
 217
 218 =cut
 219
 220 1;