mirror of
https://github.com/postgres/postgres.git
synced 2026-04-13 21:17:00 -04:00
3a7cc727c7
This complies with the perlcritic policy Subroutines::RequireFinalReturn, which is a severity 4 policy. Since we only currently check at severity level 5, the policy is raised to that level until we move to level 4 or lower, so that any new infringements will be caught. A small cosmetic piece of tidying of the pgperlcritic script is included. Mike Blackwell Discussion: https://postgr.es/m/CAESHdJpfFm_9wQnQ3koY3c91FoRQsO-fh02za9R3OEMndOn84A@mail.gmail.com
103 lines
2.1 KiB
Perl
103 lines
2.1 KiB
Perl
# src/pl/plperl/text2macro.pl
|
|
|
|
=head1 NAME
|
|
|
|
text2macro.pl - convert text files into C string-literal macro definitions
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
text2macro [options] file ... > output.h
|
|
|
|
Options:
|
|
|
|
--prefix=S - add prefix S to the names of the macros
|
|
--name=S - use S as the macro name (assumes only one file)
|
|
--strip=S - don't include lines that match perl regex S
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Reads one or more text files and outputs a corresponding series of C
|
|
pre-processor macro definitions. Each macro defines a string literal that
|
|
contains the contents of the corresponding text file. The basename of the text
|
|
file as capitalized and used as the name of the macro, along with an optional prefix.
|
|
|
|
=cut
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Getopt::Long;
|
|
|
|
GetOptions(
|
|
'prefix=s' => \my $opt_prefix,
|
|
'name=s' => \my $opt_name,
|
|
'strip=s' => \my $opt_strip,
|
|
'selftest!' => sub { exit selftest() },) or exit 1;
|
|
|
|
die "No text files specified"
|
|
unless @ARGV;
|
|
|
|
print qq{
|
|
/*
|
|
* DO NOT EDIT - THIS FILE IS AUTOGENERATED - CHANGES WILL BE LOST
|
|
* Generated by src/pl/plperl/text2macro.pl
|
|
*/
|
|
};
|
|
|
|
for my $src_file (@ARGV)
|
|
{
|
|
|
|
(my $macro = $src_file) =~ s/ .*? (\w+) (?:\.\w+) $/$1/x;
|
|
|
|
open my $src_fh, '<', $src_file
|
|
or die "Can't open $src_file: $!";
|
|
|
|
printf qq{#define %s%s \\\n},
|
|
$opt_prefix || '',
|
|
($opt_name) ? $opt_name : uc $macro;
|
|
while (<$src_fh>)
|
|
{
|
|
chomp;
|
|
|
|
next if $opt_strip and m/$opt_strip/o;
|
|
|
|
# escape the text to suite C string literal rules
|
|
s/\\/\\\\/g;
|
|
s/"/\\"/g;
|
|
|
|
printf qq{"%s\\n" \\\n}, $_;
|
|
}
|
|
print qq{""\n\n};
|
|
}
|
|
|
|
print "/* end */\n";
|
|
|
|
exit 0;
|
|
|
|
|
|
sub selftest
|
|
{
|
|
my $tmp = "text2macro_tmp";
|
|
my $string = q{a '' '\\'' "" "\\"" "\\\\" "\\\\n" b};
|
|
|
|
open my $fh, '>', "$tmp.pl" or die;
|
|
print $fh $string;
|
|
close $fh;
|
|
|
|
system("perl $0 --name=X $tmp.pl > $tmp.c") == 0 or die;
|
|
open $fh, '>>', "$tmp.c";
|
|
print $fh "#include <stdio.h>\n";
|
|
print $fh "int main() { puts(X); return 0; }\n";
|
|
close $fh;
|
|
system("cat -n $tmp.c");
|
|
|
|
system("make $tmp") == 0 or die;
|
|
open $fh, '<', "./$tmp |" or die;
|
|
my $result = <$fh>;
|
|
unlink <$tmp.*>;
|
|
|
|
warn "Test string: $string\n";
|
|
warn "Result : $result";
|
|
die "Failed!" if $result ne "$string\n";
|
|
return;
|
|
}
|