Latest update.
This commit is contained in:
@@ -0,0 +1,195 @@
|
||||
#! /usr/bin/env perl
|
||||
# Copyright 2016-2019 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
|
||||
|
||||
# Implements the functionality to read one or more template files and run
|
||||
# them through Text::Template
|
||||
|
||||
package OpenSSL::Template;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
OpenSSL::Template - a private extension of Text::Template
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This provides exactly the functionality from Text::Template, with the
|
||||
following additions:
|
||||
|
||||
=over 4
|
||||
|
||||
=item -
|
||||
|
||||
The template perl code delimiters (given with the C<DELIMITER> option)
|
||||
are set to C<{-> and C<-}> by default.
|
||||
|
||||
=item -
|
||||
|
||||
A few extra functions are offered to be used by the template perl code, see
|
||||
L</Functions>.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
use File::Basename;
|
||||
use File::Spec::Functions;
|
||||
use Text::Template 1.46;
|
||||
|
||||
our @ISA = qw(Text::Template); # parent
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
|
||||
# Call the constructor of the parent class.
|
||||
my $self = $class->SUPER::new(DELIMITERS => [ '{-', '-}'],
|
||||
@_ );
|
||||
|
||||
# Add few more attributes
|
||||
$self->{_output_off} = 0; # Default to output hunks
|
||||
|
||||
return bless $self, $class;
|
||||
}
|
||||
|
||||
sub fill_in {
|
||||
my $self = shift;
|
||||
my %opts = @_;
|
||||
my %hash = ( %{$opts{HASH}} );
|
||||
delete $opts{HASH};
|
||||
|
||||
$self->SUPER::fill_in(HASH => { quotify1 => \"ify1,
|
||||
quotify_l => \"ify_l,
|
||||
output_on => sub { $self->output_on() },
|
||||
output_off => sub { $self->output_off() },
|
||||
%hash },
|
||||
%opts);
|
||||
}
|
||||
|
||||
=head2 Functions
|
||||
|
||||
=cut
|
||||
|
||||
# Override Text::Template's append_text_to_result, as recommended here:
|
||||
#
|
||||
# http://search.cpan.org/~mjd/Text-Template-1.46/lib/Text/Template.pm#Automatic_postprocessing_of_template_hunks
|
||||
sub append_text_to_output {
|
||||
my $self = shift;
|
||||
|
||||
if ($self->{_output_off} == 0) {
|
||||
$self->SUPER::append_text_to_output(@_);
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
=begin comment
|
||||
|
||||
We lie about the OO nature of output_on() and output_off(), 'cause that's
|
||||
not how we pass them, see the HASH option used in fill_in() above
|
||||
|
||||
=end comment
|
||||
|
||||
=over 4
|
||||
|
||||
=item output_on()
|
||||
|
||||
=item output_off()
|
||||
|
||||
Switch on or off template output. Here's an example usage:
|
||||
|
||||
=over 4
|
||||
|
||||
{- output_off() if CONDITION -}
|
||||
whatever
|
||||
{- output_on() if CONDITION -}
|
||||
|
||||
=back
|
||||
|
||||
In this example, C<whatever> will only become part of the template output
|
||||
if C<CONDITION> is true.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub output_on {
|
||||
my $self = shift;
|
||||
if (--$self->{_output_off} < 0) {
|
||||
$self->{_output_off} = 0;
|
||||
}
|
||||
}
|
||||
|
||||
sub output_off {
|
||||
my $self = shift;
|
||||
$self->{_output_off}++;
|
||||
}
|
||||
|
||||
# Helper functions for the templates #################################
|
||||
|
||||
# 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.
|
||||
|
||||
# NOTE THAT THESE AREN'T CLASS METHODS!
|
||||
|
||||
=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.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub quotify_l {
|
||||
map {
|
||||
if (!defined($_)) {
|
||||
();
|
||||
} else {
|
||||
quotify1($_);
|
||||
}
|
||||
} @_;
|
||||
}
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Text::Template>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Richard Levitte E<lt>levitte@openssl.orgE<gt>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2016-2019 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
|
||||
L<https://www.openssl.org/source/license.html>.
|
||||
|
||||
=cut
|
||||
+31
-18
@@ -446,16 +446,21 @@ sub run {
|
||||
die "OpenSSL::Test::run(): statusvar value not a scalar reference"
|
||||
if $opts{statusvar} && ref($opts{statusvar}) ne "SCALAR";
|
||||
|
||||
# In non-verbose, we want to shut up the command interpreter, in case
|
||||
# it has something to complain about. On VMS, it might complain both
|
||||
# on stdout and stderr
|
||||
# For some reason, program output, or even output from this function
|
||||
# somehow isn't caught by TAP::Harness (TAP::Parser?) on VMS, so we're
|
||||
# silencing it specifically there until further notice.
|
||||
my $save_STDOUT;
|
||||
my $save_STDERR;
|
||||
if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) {
|
||||
open $save_STDOUT, '>&', \*STDOUT or die "Can't dup STDOUT: $!";
|
||||
open $save_STDERR, '>&', \*STDERR or die "Can't dup STDERR: $!";
|
||||
open STDOUT, ">", devnull();
|
||||
open STDERR, ">", devnull();
|
||||
if ($^O eq 'VMS') {
|
||||
# In non-verbose, we want to shut up the command interpreter, in case
|
||||
# it has something to complain about. On VMS, it might complain both
|
||||
# on stdout and stderr
|
||||
if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) {
|
||||
open $save_STDOUT, '>&', \*STDOUT or die "Can't dup STDOUT: $!";
|
||||
open $save_STDERR, '>&', \*STDERR or die "Can't dup STDERR: $!";
|
||||
open STDOUT, ">", devnull();
|
||||
open STDERR, ">", devnull();
|
||||
}
|
||||
}
|
||||
|
||||
$ENV{HARNESS_OSSL_LEVEL} = $level + 1;
|
||||
@@ -489,15 +494,20 @@ sub run {
|
||||
${$opts{statusvar}} = $r;
|
||||
}
|
||||
|
||||
if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) {
|
||||
close STDOUT;
|
||||
close STDERR;
|
||||
open STDOUT, '>&', $save_STDOUT or die "Can't restore STDOUT: $!";
|
||||
open STDERR, '>&', $save_STDERR or die "Can't restore STDERR: $!";
|
||||
}
|
||||
# Restore STDOUT / STDERR on VMS
|
||||
if ($^O eq 'VMS') {
|
||||
if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) {
|
||||
close STDOUT;
|
||||
close STDERR;
|
||||
open STDOUT, '>&', $save_STDOUT or die "Can't restore STDOUT: $!";
|
||||
open STDERR, '>&', $save_STDERR or die "Can't restore STDERR: $!";
|
||||
}
|
||||
|
||||
print STDERR "$prefix$display_cmd => $e\n"
|
||||
if !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};
|
||||
print STDERR "$prefix$display_cmd => $e\n"
|
||||
if !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};
|
||||
} else {
|
||||
print STDERR "$prefix$display_cmd => $e\n";
|
||||
}
|
||||
|
||||
# At this point, $? stops being interesting, and unfortunately,
|
||||
# there are Test::More versions that get picky if we leave it
|
||||
@@ -1244,8 +1254,11 @@ sub __decorate_cmd {
|
||||
|
||||
my $display_cmd = "$cmdstr$stdin$stdout$stderr";
|
||||
|
||||
$stderr=" 2> ".$null
|
||||
unless $stderr || !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};
|
||||
# VMS program output escapes TAP::Parser
|
||||
if ($^O eq 'VMS') {
|
||||
$stderr=" 2> ".$null
|
||||
unless $stderr || !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};
|
||||
}
|
||||
|
||||
$cmdstr .= "$stdin$stdout$stderr";
|
||||
|
||||
|
||||
@@ -0,0 +1,112 @@
|
||||
# Copyright 2019 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
|
||||
|
||||
=head1 NAME
|
||||
|
||||
OpenSSL::fallback - push directories to the end of @INC at compile time
|
||||
|
||||
=cut
|
||||
|
||||
package OpenSSL::fallback;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
|
||||
our $VERSION = '0.01';
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use OpenSSL::fallback LIST;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This small simple module simplifies the addition of fallback directories
|
||||
in @INC at compile time.
|
||||
|
||||
It is used to add extra directories at the end of perl's search path so
|
||||
that later "use" or "require" statements will find modules which are not
|
||||
located on perl's default search path.
|
||||
|
||||
This is similar to L<lib>, except the paths are I<appended> to @INC rather
|
||||
than prepended, thus allowing the use of a newer module on perl's default
|
||||
search path if there is one.
|
||||
|
||||
=head1 CAVEAT
|
||||
|
||||
Just like with B<lib>, this only works with Unix filepaths.
|
||||
Just like with L<lib>, this doesn't mean that it only works on Unix, but that
|
||||
non-Unix users must first translate their file paths to Unix conventions.
|
||||
|
||||
# VMS users wanting to put [.my.stuff] into their @INC should write:
|
||||
use fallback 'my/stuff';
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
If you try to add a file to @INC as follows, you will be warned, and the file
|
||||
will be ignored:
|
||||
|
||||
use fallback 'file.txt';
|
||||
|
||||
The sole exception is the file F<MODULES.txt>, which must contain a list of
|
||||
sub-directories relative to the location of that F<MODULES.txt> file.
|
||||
All these sub-directories will be appended to @INC.
|
||||
|
||||
=cut
|
||||
|
||||
# Forward declare
|
||||
sub glob;
|
||||
|
||||
use constant DEBUG => 0;
|
||||
|
||||
sub import {
|
||||
shift; # Skip module name
|
||||
|
||||
foreach (@_) {
|
||||
my $path = $_;
|
||||
|
||||
if ($path eq '') {
|
||||
carp "Empty compile time value given to use fallback";
|
||||
next;
|
||||
}
|
||||
|
||||
print STDERR "DEBUG: $path\n" if DEBUG;
|
||||
|
||||
unless (-e $path
|
||||
&& ($path =~ m/(?:^|\/)MODULES.txt/ || -d $path)) {
|
||||
croak "Parameter to use fallback must be a directory, not a file";
|
||||
next;
|
||||
}
|
||||
|
||||
my @dirs = ();
|
||||
if (-f $path) { # It's a MODULES.txt file
|
||||
(my $dir = $path) =~ s|/[^/]*$||; # quick dirname
|
||||
open my $fh, $path or die "Could not open $path: $!\n";
|
||||
while (my $l = <$fh>) {
|
||||
$l =~ s|\R$||; # Better chomp
|
||||
my $d = "$dir/$l";
|
||||
croak "All lines in $path must be a directory, not a file: $l"
|
||||
unless -e $d && -d $d;
|
||||
push @INC, $d;
|
||||
}
|
||||
} else { # It's a directory
|
||||
push @INC, $path;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<FindBin> - optional module which deals with paths relative to the source
|
||||
file.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Richard Levitte, 2019
|
||||
|
||||
=cut
|
||||
|
||||
Reference in New Issue
Block a user