642 lines
24 KiB
Perl
Executable file
642 lines
24 KiB
Perl
Executable file
#! /usr/bin/perl -w
|
|
# written April 1996, <tale@isc.org> (David C Lawrence)
|
|
# Currently maintained by Russ Allbery <eagle@eyrie.org>
|
|
# Version 1.9, 2016-10-17
|
|
#
|
|
# sequoia-sq support written in December 2024 by
|
|
# Fabrizio Tarizzo <fabrizio@fabriziotarizzo.org>
|
|
#
|
|
# Changes from 1.8 -> 1.9
|
|
# -- Add use strict and explicitly import LOCK_EX.
|
|
# -- Fix error reporting around lock files with PGP.
|
|
# -- Use https for pgpcontrol URLs.
|
|
#
|
|
# Changes from 1.6 -> 1.8
|
|
# -- Added support for GnuPG.
|
|
# -- Replace signing code with code from PGP::Sign that generates detached
|
|
# signatures instead. Otherwise, GnuPG signatures with DSA keys could
|
|
# not be verified. Should still work the same as before with RSA keys.
|
|
# -- Thanks to new signing code, no longer uses a temporary file.
|
|
# -- Only lock when using PGP; GnuPG shouldn't need it.
|
|
#
|
|
# Changes from 1.5 -> 1.6
|
|
# -- eliminated subprocess use (except pgp, of course).
|
|
# -- interlock against competing signing processes.
|
|
# -- allow optional headers; see $use_or_add.
|
|
# -- added simple comments about why particular headers are signed.
|
|
# -- made error messages a tad more helpful for situations when it is hard
|
|
# to know what message was trying to be signed (such as via an "at"
|
|
# job).
|
|
# -- set $action, $group, $moderated to "" to prevent unusued variable
|
|
# warnings in the event a Control header can't be parsed.
|
|
# -- moved assignment of $pgpend out of loop.
|
|
#
|
|
# Changes from 1.4 -> 1.5
|
|
# -- need to require Text::Tabs to get 'expand' for tabs in checkgroups.
|
|
#
|
|
# Changes from 1.3 -> 1.4
|
|
# -- added checkgroups checking.
|
|
# -- added group name in several error messages (for help w/batch
|
|
# processing).
|
|
# -- disabled moderator address checking.
|
|
# -- adjusted newsgroups line (ie, tabbing fixed) now correctly
|
|
# substituted into control message.
|
|
#
|
|
# Changes from 1.2.3 -> 1.3
|
|
# -- skip minor pgp signature headers like "charset:" after "version:"
|
|
# header and until the empty line that starts the base64 signature block.
|
|
|
|
use strict;
|
|
|
|
# CONFIGURATION
|
|
|
|
# PGP variables.
|
|
#
|
|
# $pgp can be set to the path to GnuPG to use GnuPG instead. The program
|
|
# name needs to end in gpg so that signcontrol knows GnuPG is being used.
|
|
# $pgp can be set to the path to sq to use sequoia. The program name needs
|
|
# to end in sq so that signcontrol knows sequoia is being used.
|
|
#
|
|
# STORING YOUR PASSPHRASE IN A FILE IS A POTENTIAL SECURITY HOLE.
|
|
# Make sure you know what you're doing if you do it.
|
|
# If you don't use $pgppassfile, you can only use this script interactively.
|
|
# If you DO use $pgppassfile, it is possible that someone could steal
|
|
# your passphrase either by gaining access to the file or by seeing
|
|
# the environment of a running pgpverify program.
|
|
# $pgppassfile IS NOT currently supported by sequoia
|
|
#
|
|
# $pgplock is used because pgp does not guard itself against concurrent
|
|
# read/write access to its randseed.bin file. A writable file is needed;
|
|
# The default value is to use the .pgp/config.txt file in the home
|
|
# directory of the user running the program. Note that this will only
|
|
# work to lock against other instances of signcontrol, not all pgp uses.
|
|
# $pgplock is not used if $pgp ends in 'gpg' since GnuPG doesn't need
|
|
# this.
|
|
my $pgpsigner = 'INSERT_YOUR_PGP_USERID';
|
|
my $pgppassfile = ''; # file with pass phrase for $pgpsigner
|
|
my $pgp = "/usr/local/bin/sq";
|
|
my $pgpheader = "X-PGP-Sig";
|
|
my $pgplock = (getpwuid($<))[7] . '/.pgp/config.txt';
|
|
|
|
# this program is strict about always wanting to be consistent about what
|
|
# headers appear in the control messages. the defaults for the
|
|
# @... arrays are reasonable, but you should edit the force values.
|
|
|
|
# these headers are acceptable in input, but they will be overwritten with
|
|
# these values. no sanity checking is done on what you put here. also,
|
|
# Subject: is forced to be the Control header prepending by "cmsg". also,
|
|
# Newsgroups: is forced to be just the group being added/removed.
|
|
# (but is taken as-is for checkgroups)
|
|
my %force;
|
|
$force{'Path'} = 'bounce-back';
|
|
$force{'From'} = 'YOUR_ADDRESS_AND_NAME';
|
|
$force{'Approved'} = 'ADDRESS_FOR_Approved_HEADER';
|
|
$force{'X-Info'}='https://ftp.isc.org/pub/pgpcontrol/README.html'
|
|
. "\n\t"
|
|
. 'https://ftp.isc.org/pub/pgpcontrol/README';
|
|
|
|
# these headers are acceptable in input, or if not present then will be
|
|
# created with the given value. None are enabled by default, because they
|
|
# should not be necessary. Setting one to a null string will pass through
|
|
# any instance of it found in the input, but not generate one if it is
|
|
# missing. If you set any $use_or_add{} variables, you must also put it in
|
|
# @orderheaders below.
|
|
#
|
|
# Note that Distribution nearly never works correctly, so use it only if
|
|
# you are really sure the propagation of the article will be limited as
|
|
# you intend. This normally means that you control all servers the
|
|
# distribution will go to with an iron fist.
|
|
#
|
|
my %use_or_add;
|
|
# $use_or_add{'Reply-To'} = 'YOUR_REPLY_ADDRESS';
|
|
# $use_or_add{'Oranization'} = 'YOUR_ORGANIZATION';
|
|
# $use_or_add{'Distribution'} = 'MESSAGE_DISTRIBUTION';
|
|
|
|
# host for message-id; this could be determined automatically based on
|
|
# where it is run, but consistency is the goal here
|
|
my $id_host = 'FULL_HOST_NAME';
|
|
|
|
# headers to sign. Sender is included because non-PGP authentication uses
|
|
# it. The following should always be signed:
|
|
# Subject -- some older news systems use it to identify the control action.
|
|
# Control -- most news systems use this to determine what to do.
|
|
# Message-ID -- guards against replay attacks.
|
|
# Date -- guards against replay attacks.
|
|
# From -- used by news systems as part of authenticating the message.
|
|
# Sender -- used by news systems as part of authenticating the message.
|
|
my @signheaders = ('Subject', 'Control', 'Message-ID', 'Date', 'From', 'Sender');
|
|
|
|
# headers to remove from real headers of final message.
|
|
# If it is a signed header, it is signed with an empty value.
|
|
# set to () if you do not want any headers removed.
|
|
my @ignoreheaders = ('Sender');
|
|
|
|
# headers that will appear in final message, and their order of
|
|
# appearance. all _must_ be set, either in input or via the $force{} and
|
|
# $use_or_add{} variables above.
|
|
# (exceptions: Date, Lines, Message-ID are computed by this program)
|
|
# if header is in use_or_add with a null value, it will not appear in output.
|
|
# several are required by the news article format standard; if you remove
|
|
# these, your article will not propagate:
|
|
# Path, From, Newsgroups, Subject, Message-ID, Date
|
|
# if you take out these, your control message is not very useful:
|
|
# Control, Approved
|
|
# any headers in @ignoreheaders also in @orderheaders are silently dropped.
|
|
# any non-null header in the input but not in @orderheaders or @ignoreheaders
|
|
# is an error.
|
|
# null headers are silently dropped.
|
|
my @orderheaders =
|
|
('Path', 'From', 'Newsgroups', 'Subject', 'Control', 'Approved',
|
|
'Message-ID', 'Date', 'Lines', 'X-Info', $pgpheader);
|
|
|
|
# this program tries to help you out by not letting you sign erroneous
|
|
# names, especially ones that are so erroneous they run afoul of naming
|
|
# standards.
|
|
#
|
|
# set to match only hierarchies you will use it on
|
|
# include no '|' for a single hierarchy (eg, "$hierarchies = 'uk';").
|
|
|
|
my $hierarchies = 'HIERARCHIES';
|
|
|
|
# the draft news article format standard says:
|
|
# "subsequent components SHOULD begin with a letter"
|
|
# where "SHOULD" means:
|
|
# means that the item is a strong recommendation: there may be
|
|
# valid reasons to ignore it in unusual circumstances, but
|
|
# this should be done only after careful study of the full
|
|
# implications and a firm conclusion that it is necessary,
|
|
# because there are serious disadvantages to doing so.
|
|
# as opposed to "MUST" which means:
|
|
# means that the item is an absolute requirement of the specification
|
|
# MUST is preferred, but might not be acceptable if you have legacy
|
|
# newsgroups that have name components that begin with a letter, like
|
|
# news.announce.newgroups does with comp.sys.3b1 and 17 other groups.
|
|
|
|
my $start_component_with_letter = 'MUST';
|
|
|
|
## END CONFIGURATION
|
|
|
|
use Fcntl qw(F_SETFD LOCK_EX);
|
|
use FileHandle;
|
|
use IPC::Open3 qw(open3);
|
|
use POSIX qw(setlocale strftime LC_TIME);
|
|
use Text::Tabs; # to get 'expand' for tabs in checkgroups
|
|
|
|
$0 =~ s#^.*/##;
|
|
|
|
die "Usage: $0 < message\n" if @ARGV > 0;
|
|
|
|
my $LOCK;
|
|
umask(0022); # flock needs a writable file, if we create it
|
|
if ($pgp !~ /gpg$/ && $pgp !~ /sq$/) {
|
|
open ($LOCK, '>>', $pgplock) || die "$0: open $pgplock: $!, exiting\n";
|
|
flock ($LOCK, LOCK_EX); # block until locked
|
|
}
|
|
|
|
my ($die, $group, $action, $grouppat, %header, $moderated, $body, @ERROR);
|
|
|
|
# Initialize the $die variable here (we use it to concatenate possible
|
|
# error messages during the run of the following functions).
|
|
$die = '';
|
|
|
|
setgrouppat();
|
|
|
|
readhead();
|
|
readbody();
|
|
|
|
if ($die) {
|
|
if ($group) {
|
|
die "$0: ERROR PROCESSING ${action}group $group:\n", $die;
|
|
} elsif ($action eq 'check') {
|
|
die "$0: ERROR PROCESSING checkgroups:\n", $die;
|
|
} elsif ($header{'Subject'}) {
|
|
die "$0: ERROR PROCESSING Subject: $header{'Subject'}\n", $die;
|
|
} else {
|
|
die $die;
|
|
}
|
|
}
|
|
|
|
signit();
|
|
|
|
if ($pgp !~ /gpg$/ && $pgp !~ /sq$/) {
|
|
close ($LOCK) || warn "$0: close $pgplock: $!\n";
|
|
}
|
|
exit 0;
|
|
|
|
|
|
|
|
sub setgrouppat {
|
|
my ($plain_component, $no_component);
|
|
my ($must_start_letter, $should_start_letter);
|
|
|
|
# newsgroup name checks based on RFC 1036bis (not including encodings) rules:
|
|
# "component MUST contain at least one letter"
|
|
# "[component] MUST not contain uppercase letters"
|
|
# "[component] MUST begin with a letter or digit"
|
|
# "[component] MUST not be longer than 14 characters"
|
|
# "sequences 'all' and 'ctl' MUST not be used as components"
|
|
# "first component MUST begin with a letter"
|
|
# and enforcing "subsequent components SHOULD begin with a letter" as MUST
|
|
# and enforcing at least a 2nd level group (can't use to newgroup "general")
|
|
#
|
|
# DO NOT COPY THIS PATTERN BLINDLY TO OTHER APPLICATIONS!
|
|
# It has special construction based on the pattern it is finally used in.
|
|
|
|
$plain_component = '[a-z][-+_a-z\d]{0,13}';
|
|
$no_component = '(.*\.)?(all|ctl)(\.|$)';
|
|
$must_start_letter = '(\.' . $plain_component . ')+';
|
|
$should_start_letter = '(\.(?=\d*[a-z])[a-z\d]+[-+_a-z\d]{0,13})+';
|
|
|
|
$grouppat = "(?!$no_component)($hierarchies)";
|
|
if ($start_component_with_letter eq 'SHOULD') {
|
|
$grouppat .= $should_start_letter;
|
|
} elsif ($start_component_with_letter eq 'MUST') {
|
|
$grouppat .= $must_start_letter;
|
|
} else {
|
|
die "$0: unknown value configured for \$start_component_with_letter\n";
|
|
}
|
|
|
|
foreach my $hierarchy (split /\|/, $hierarchies) {
|
|
die "$0: hierarchy name $hierarchy not standards-compliant\n"
|
|
if $hierarchy !~ /^$plain_component$/o;
|
|
}
|
|
|
|
eval { 'test' =~ /$grouppat/ };
|
|
die "$0: bad regexp for matching group names:\n $@" if $@;
|
|
return;
|
|
}
|
|
|
|
sub readhead {
|
|
my ($head, $label, $value);
|
|
|
|
local $/ = "";
|
|
$head = <STDIN>; # get the whole news header
|
|
$die .= "$0: continuation lines in headers not allowed\n"
|
|
if $head =~ s/\n[ \t]+/ /g; # rejoin continued lines
|
|
|
|
foreach (split /\n/, $head) {
|
|
if (/^(\S+): (.*)/) {
|
|
$label = $1;
|
|
$value = $2;
|
|
|
|
$die .= "$0: duplicate header $label\n" if $header{$label};
|
|
|
|
$header{$label} = $value;
|
|
$header{$label} =~ s/^\s+//;
|
|
$header{$label} =~ s/\s+$//;
|
|
} elsif (/^$/) {
|
|
; # the empty line separator(s)
|
|
} else {
|
|
$die .= "$0: non-header line:\n $_\n";
|
|
}
|
|
}
|
|
|
|
$header{'Message-ID'} = '<' . time . ".$$\@$id_host>";
|
|
|
|
setlocale(LC_TIME, "C");
|
|
$header{'Date'} = strftime("%a, %d %h %Y %T -0000", gmtime);
|
|
|
|
for (@ignoreheaders) {
|
|
$die .= "ignored header $_ also has forced value set\n" if $force{$_};
|
|
$header{$_} = '';
|
|
}
|
|
|
|
for (@orderheaders) {
|
|
$header{$_} = $force{$_} if defined($force{$_});
|
|
next if /^(Lines|\Q$pgpheader\E)$/; # these are set later
|
|
unless ($header{$_}) {
|
|
if (defined($use_or_add{$_})) {
|
|
$header{$_} = $use_or_add{$_} if $use_or_add{$_} ne '';
|
|
} else {
|
|
$die .= "$0: missing $_ header\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
$action = $group = $moderated = "";
|
|
if ($header{'Control'}) {
|
|
if ($header{'Control'} =~ /^(new)group (\S+)( moderated)?$/o ||
|
|
$header{'Control'} =~ /^(rm)group (\S+)()$/o ||
|
|
$header{'Control'} =~ /^(check)groups()()$/o) {
|
|
($action, $group, $moderated) = ($1, $2, $3);
|
|
$die .= "$0: group name $group is not standards-compliant\n"
|
|
if $group !~ /^$grouppat$/ && $action eq 'new';
|
|
$die .= "$0: no group to rmgroup on Control: line\n"
|
|
if ! $group && $action eq 'rm';
|
|
$header{'Subject'} = "cmsg $header{'Control'}";
|
|
$header{'Newsgroups'} = $group unless $action eq 'check';
|
|
} else {
|
|
$die .= "$0: bad Control format: $header{'Control'}\n";
|
|
}
|
|
} else {
|
|
$die .= "$0: can't verify message content; missing Control header\n";
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub readbody {
|
|
my ($status, $ngline, $fixline, $used, $desc, $mods);
|
|
|
|
local $/ = undef;
|
|
$body = <STDIN>; # slurp the rest of the article
|
|
$header{'Lines'} = $body =~ tr/\n/\n/ if $body;
|
|
|
|
# the following tests are based on the structure of a
|
|
# news.announce.newgroups newgroup message; even if you comment out the
|
|
# "first line" test, please leave the newsgroups line and moderators
|
|
# checks
|
|
if ($action eq 'new') {
|
|
$status = $moderated ? 'a\smoderated' : 'an\sunmoderated';
|
|
$die .= "$0: nonstandard first line in body for $group\n"
|
|
if $body !~ /^\Q$group\E\sis\s$status\snewsgroup\b/;
|
|
|
|
my $intro = "For your newsgroups file:\n";
|
|
$ngline =
|
|
($body =~ /^$intro\Q$group\E[ \t]+(.+)\n(\n|\Z(?!\n))/mi)[0];
|
|
if ($ngline) {
|
|
$_ = $group;
|
|
$desc = $1;
|
|
$fixline = $_;
|
|
$fixline .= "\t" x ((length) > 23 ? 1 : (4 - ((length) + 1) / 8));
|
|
$used = (length) < 24 ? 24 : (length) + (8 - (length) % 8);
|
|
$used--;
|
|
$desc =~ s/ \(Moderated\)//i;
|
|
$desc =~ s/\s+$//;
|
|
$desc =~ s/\w$/$&./;
|
|
$die .= "$0: $group description too long\n" if $used + length($desc) > 80;
|
|
$fixline .= $desc;
|
|
$fixline .= ' (Moderated)' if $moderated;
|
|
$body =~ s/^$intro(.+)/$intro$fixline/mi;
|
|
} else {
|
|
$die .= "$0: $group newsgroup line not formatted correctly\n";
|
|
}
|
|
# moderator checks are disabled; some sites were trying to
|
|
# automatically maintain aliases based on this, which is bad policy.
|
|
if (0 && $moderated) {
|
|
$die .= "$0: $group submission address not formatted correctly\n"
|
|
if $body !~ /\nGroup submission address: ?\S+@\S+\.\S+\n/m;
|
|
$mods = "( |\n[ \t]+)\\([^)]+\\)\n\n";
|
|
$die .= "$0: $group contact address not formatted correctly\n"
|
|
if $body !~ /\nModerator contact address: ?\S+@\S+\.\S+$mods/m;
|
|
}
|
|
}
|
|
# rmgroups have freeform bodies
|
|
|
|
# checkgroups have structured bodies
|
|
if ($action eq 'check') {
|
|
for (split /\n/, $body) {
|
|
my ($group, $description) = /^(\S+)\t+(.+)/;
|
|
$die .= "$0: no group:\n $_\n" unless $group;
|
|
$die .= "$0: no description:\n $_\n" unless $description;
|
|
$die .= "$0: bad group name \"$group\"\n" if $group !~ /^$grouppat$/;
|
|
$die .= "$0: tab in description\n" if $description =~ /\t/;
|
|
s/ \(Moderated\)$//;
|
|
$die .= "$0: $group line too long\n" if length(expand($_)) > 80;
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
# Create a detached signature for the given data. The first argument
|
|
# should be a key id, the second argument the PGP passphrase (which may be
|
|
# null, in which case PGP will prompt for it), and the third argument
|
|
# should be the complete message to sign.
|
|
#
|
|
# In a scalar context, the signature is returned as an ASCII-armored block
|
|
# with embedded newlines. In array context, a list consisting of the
|
|
# signature and the PGP version number is returned. Returns undef in the
|
|
# event of an error, and the error text is then stored in @ERROR.
|
|
#
|
|
# This function is taken almost verbatim from PGP::Sign except the PGP
|
|
# style is determined from the name of the program used.
|
|
sub pgp_sign {
|
|
my ($keyid, $passphrase, $message) = @_;
|
|
|
|
# Ignore SIGPIPE, since we're going to be talking to PGP.
|
|
local $SIG{PIPE} = 'IGNORE';
|
|
|
|
# Determine the PGP style.
|
|
my $pgpstyle = 'PGP2';
|
|
if ($pgp =~ /pgps$/) { $pgpstyle = 'PGP5' }
|
|
elsif ($pgp =~ /gpg$/) { $pgpstyle = 'GPG' }
|
|
elsif ($pgp =~ /sq$/) { $pgpstyle = 'SEQUOIA' }
|
|
|
|
# Figure out what command line we'll be using. PGP v6 and PGP v2 use
|
|
# compatible syntaxes for what we're trying to do. PGP v5 would have,
|
|
# except that the -s option isn't valid when you call pgps. *sigh*
|
|
my @command;
|
|
my $versioncommand;
|
|
|
|
if ($pgpstyle eq 'PGP5') {
|
|
@command = ($pgp, qw/-baft -u/, $keyid);
|
|
} elsif ($pgpstyle eq 'SEQUOIA') {
|
|
@command = ($pgp, "sign");
|
|
|
|
# Check if $keyid looks like a long Key ID (16 hex digits)
|
|
# or a key fingerprint (40 hex digits for RFC 4880 keys and
|
|
# 64 hex digits for RFC 9580 keys)
|
|
# Short (8 hex digits) Key IDs are deprecated and not supported
|
|
my $len = length($keyid);
|
|
if ($keyid =~ /^[0-9A-F]+$/ and grep /^$len$/, qw(16 40 64)) {
|
|
push (@command, "--signer=$keyid");
|
|
} else {
|
|
# otherwise treat it as a User ID
|
|
push (@command, "--signer-userid=$keyid");
|
|
}
|
|
|
|
push (@command, "--signature-file=-");
|
|
$versioncommand = "$pgp version";
|
|
} elsif ($pgpstyle eq 'GPG') {
|
|
@command = ($pgp, qw/--detach-sign --armor --textmode -u/, $keyid,
|
|
qw/--force-v3-sigs --pgp2/);
|
|
} else {
|
|
@command = ($pgp, qw/-sbaft -u/, $keyid);
|
|
}
|
|
|
|
# We need to send the password to PGP, but we don't want to use either
|
|
# the command line or an environment variable, since both may expose us
|
|
# to snoopers on the system. So we create a pipe, stick the password in
|
|
# it, and then pass the file descriptor to PGP. PGP wants to know about
|
|
# this in an environment variable; GPG uses a command-line flag.
|
|
# 5.005_03 started setting close-on-exec on file handles > $^F, so we
|
|
# need to clear that here (but ignore errors on platforms where fcntl or
|
|
# F_SETFD doesn't exist, if any).
|
|
#
|
|
# Make sure that the file handles are created outside of the if
|
|
# statement, since otherwise they leave scope at the end of the if
|
|
# statement and are automatically closed by Perl.
|
|
my $passfh = new FileHandle;
|
|
my $writefh = new FileHandle;
|
|
local $ENV{PGPPASSFD};
|
|
if ($passphrase) {
|
|
pipe ($passfh, $writefh);
|
|
eval { fcntl ($passfh, F_SETFD, 0) };
|
|
print $writefh $passphrase;
|
|
close $writefh;
|
|
if ($pgpstyle eq 'GPG') {
|
|
push (@command, '--batch', '--passphrase-fd', $passfh->fileno);
|
|
} elsif ($pgpstyle eq 'SEQUOIA') {
|
|
# Currently unsupported
|
|
} else {
|
|
push (@command, '+batchmode');
|
|
$ENV{PGPPASSFD} = $passfh->fileno;
|
|
}
|
|
}
|
|
|
|
# Fork off a pgp process that we're going to be feeding data to, and tell
|
|
# it to just generate a signature using the given key id and pass phrase.
|
|
my $pgp = new FileHandle;
|
|
my $signature = new FileHandle;
|
|
my $errors = new FileHandle;
|
|
my $pid = eval { open3 ($pgp, $signature, $errors, @command) };
|
|
if ($@) {
|
|
@ERROR = ($@, "Execution of $command[0] failed.\n");
|
|
return undef;
|
|
}
|
|
|
|
# Write the message to the PGP process. Strip all trailing whitespace
|
|
# for compatibility with older pgpverify and attached signature
|
|
# verification.
|
|
$message =~ s/[ \t]+\n/\n/g;
|
|
print $pgp $message;
|
|
|
|
# All done. Close the pipe to PGP, clean up, and see if we succeeded.
|
|
# If not, save the error output and return undef.
|
|
close $pgp;
|
|
local $/ = "\n";
|
|
my @errors = <$errors>;
|
|
my @signature = <$signature>;
|
|
close $signature;
|
|
close $errors;
|
|
close $passfh if $passphrase;
|
|
waitpid ($pid, 0);
|
|
if ($? != 0) {
|
|
@ERROR = (@errors, "$command[0] returned exit status $?\n");
|
|
return undef;
|
|
}
|
|
|
|
# Now, clean up the returned signature and return it, along with the
|
|
# version number if desired. PGP v2 calls this a PGP MESSAGE, whereas
|
|
# PGP v5 and v6 and GPG both (more correctly) call it a PGP SIGNATURE,
|
|
# so accept either.
|
|
while ((shift @signature) !~ /-----BEGIN PGP \S+-----\n/) {
|
|
unless (@signature) {
|
|
@ERROR = ("No signature from PGP (command not found?)\n");
|
|
return undef;
|
|
}
|
|
}
|
|
my $version;
|
|
while ($signature[0] ne "\n" && @signature) {
|
|
$version = $1 if ((shift @signature) =~ /^Version:\s+(.*?)\s*$/);
|
|
}
|
|
|
|
# sequoia does not add the Version header in armored output,
|
|
# as per RFC 9580 section 6.2.2.1
|
|
if ($pgpstyle eq 'SEQUOIA') {
|
|
my @version = qx/$versioncommand 2>&1/;
|
|
$version = shift @version;
|
|
chomp $version;
|
|
$version =~ s/\s+/_/;
|
|
}
|
|
|
|
shift @signature;
|
|
pop @signature;
|
|
$signature = join '', @signature;
|
|
chomp $signature;
|
|
undef @ERROR;
|
|
return wantarray ? ($signature, $version) : $signature;
|
|
}
|
|
|
|
sub signit {
|
|
my ($head, $signheaders);
|
|
|
|
# Form the message to be signed.
|
|
$signheaders = join ",", @signheaders;
|
|
$head = "X-Signed-Headers: $signheaders\n";
|
|
foreach my $header (@signheaders) {
|
|
$head .= "$header: $header{$header}\n";
|
|
}
|
|
my $message = "$head\n$body";
|
|
|
|
# Get the passphrase if available.
|
|
my $passphrase;
|
|
if ($pgppassfile && -f $pgppassfile) {
|
|
$pgppassfile =~ s%^(\s)%./$1%;
|
|
if (open my $PGPPASS, '<', $pgppassfile) {
|
|
$passphrase = <$PGPPASS>;
|
|
close $PGPPASS;
|
|
chomp $passphrase;
|
|
}
|
|
}
|
|
|
|
# Sign the message, getting the signature and PGP version number.
|
|
my ($signature, $version) = pgp_sign($pgpsigner, $passphrase, $message);
|
|
unless ($signature) {
|
|
die "@ERROR\n$0: could not generate signature\n";
|
|
}
|
|
|
|
# GnuPG has version numbers containing spaces, which breaks our header
|
|
# format. Find just some portion that contains a digit.
|
|
($version) = ($version =~ /(\S*\d\S*)/);
|
|
|
|
# Put the signature into the headers.
|
|
$signature =~ s/^/\t/mg;
|
|
$header{$pgpheader} = "$version $signheaders\n$signature";
|
|
|
|
for (@ignoreheaders) {
|
|
delete $header{$_} if defined $header{$_};
|
|
}
|
|
|
|
$head = '';
|
|
foreach my $header (@orderheaders) {
|
|
$head .= "$header: $header{$header}\n" if $header{$header};
|
|
delete $header{$header};
|
|
}
|
|
|
|
foreach my $header (keys %header) {
|
|
die "$0: unexpected header $header left in header array\n";
|
|
}
|
|
|
|
print STDOUT $head;
|
|
print STDOUT "\n";
|
|
print STDOUT $body;
|
|
return;
|
|
}
|
|
|
|
# Our lawyer told me to include the following. The upshot of it is that
|
|
# you can use the software for free as much as you like.
|
|
|
|
# Copyright (c) 1996 UUNET Technologies, Inc.
|
|
# All rights reserved.
|
|
#
|
|
# Redistribution and use in source and binary forms, with or without
|
|
# modification, are permitted provided that the following conditions
|
|
# are met:
|
|
# 1. Redistributions of source code must retain the above copyright
|
|
# notice, this list of conditions and the following disclaimer.
|
|
# 2. Redistributions in binary form must reproduce the above copyright
|
|
# notice, this list of conditions and the following disclaimer in the
|
|
# documentation and/or other materials provided with the distribution.
|
|
# 3. All advertising materials mentioning features or use of this software
|
|
# must display the following acknowledgement:
|
|
# This product includes software developed by UUNET Technologies, Inc.
|
|
# 4. The name of UUNET Technologies ("UUNET") may not be used to endorse or
|
|
# promote products derived from this software without specific prior
|
|
# written permission.
|
|
#
|
|
# THIS SOFTWARE IS PROVIDED BY UUNET ``AS IS'' AND ANY EXPRESS OR
|
|
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
|
# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
|
# ARE DISCLAIMED. IN NO EVENT SHALL UUNET BE LIABLE FOR ANY DIRECT,
|
|
# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
|
|
# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
|
|
# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
|
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
|
|
# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
|
|
# OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
|
|
# Local variables:
|
|
# cperl-indent-level: 2
|
|
# fill-column: 74
|
|
# End:
|