scripts/LinuxStableQueue.pm

package LinuxStableQueue;

use strict;
use warnings;
use Config::Simple;
use Cwd ();
use File::Path ();
use MIME::Words ();
use POSIX ();

BEGIN {
    use Exporter ();

    our (@ISA, @EXPORT_OK);

    @ISA = qw(Exporter);
    @EXPORT_OK = qw($STABLE_QUEUES %STABLE_GIT $UPSTREAM_GIT $MAIL_FROM
		    $MAIL_ANNOUNCE_TO $MAIL_ANNOUNCE_CC $MAIL_REVIEW_TO
		    $MAIL_REVIEW_COVER_CC $MAIL_REVIEW_CC $STABLE_RC_URL
	            &base_version &last_update &next_update &get_queue
		    &get_git &common_mail_header
		    &mime_entity_to_mbox &print_signature &parse_mailbox_addr
		    &mailbox_addr_to_addr_spec &make_mailbox_addr
		    &parse_mailbox_list &quilt_dir_from_git_dir);
}

our ($STABLE_QUEUES, %STABLE_GIT, $UPSTREAM_GIT, $MAIL_FROM,
     $MAIL_ANNOUNCE_TO, $MAIL_ANNOUNCE_CC, $MAIL_REVIEW_TO,
     $MAIL_REVIEW_COVER_CC, $MAIL_REVIEW_CC);

# Config::Simple does a reasonably good job of parsing shell variable
# assignments.
my $config = new Config::Simple(
    filename => "${ENV{HOME}}/.config/linux-stable-queue",
    syntax => 'simple');
my $vars = $config->vars();

# Convert each known config variable to a module-level variable,
# except for STABLE_GIT_* which we convert to a single variable.
for my $key (keys %$vars) {
    if ($key =~ /^default\.(STABLE_QUEUES|UPSTREAM_GIT|MAIL_(?:FROM|ANNOUNCE_(?:TO|CC)|REVIEW_(?:TO|COVER_CC|CC))|STABLE_RC_URL)$/) {
	no strict 'refs';
	${$1} = $vars->{$key};
    } elsif ($key =~ /^default\.STABLE_GIT_([\d_]+)$/) {
	my $base = $1;
	$base =~ s/_/./g;
	$STABLE_GIT{$base} = $vars->{$key};
    }
}

# Get base version, i.e. the Linus stable release that a version is based on
sub base_version {
    my ($ver) = @_;
    $ver =~ s/-rc.*$//;
    $ver =~ s/^((?:2\.6|[3-9]|..)\..*)\..*/$1/;
    return $ver;
}

sub add_update {
    my ($ver, $delta) = @_;
    my ($base, $update);
    $base = base_version($ver);
    $update = $ver;
    $update =~ s/^\Q$base.\E// or $update = 0;;
    $update += $delta;
    return ($update == 0) ? $base : "$base.$update";
}

# Get last stable update version (or Linus stable release, for .1)
sub last_update {
    my ($ver) = @_;
    return add_update($ver, -1);
}

# Get next stable update version
sub next_update {
    my ($ver) = @_;
    return add_update($ver, 1);
}

# Get patch queue directory for a given base version
sub get_queue {
    my ($base) = @_;
    my $queue = "$STABLE_QUEUES/queue-$base";
    File::Path::make_path $queue or die "$!";
    return $queue;
}

# Get git repo directory for a given base version
sub get_git {
    my ($base) = @_;
    return $STABLE_GIT{$base};
}

# We want messages to display in the right order if sorted by either
# Subject or Date.  The Date field only has 1 second resolution, so
# add 1 second for each message.
my $mail_time;
sub next_mail_time {
    if ($mail_time) {
	++$mail_time;
    } else {
	$mail_time = time();
    }
    return $mail_time;
}

# Return common mail header fields
sub common_mail_header {
    # XXX Surely there are common utilities for this?
    my $date = POSIX::strftime('%a, %d %b %Y %H:%M:%S %z',
			       localtime(next_mail_time()));
    my $domain = $MAIL_FROM;
    $domain =~ s/>?\s*$//;
    $domain =~ s/^.*\@//;
    my $mid = '<lsq.' . time() . '.' . int(rand(1e9)) . "\@$domain>";
    return (Date => $date,
	    'Message-Id' => $mid,
	    'X-Mailer' => 'LinuxStableQueue (scripts by bwh)',
	    'X-Patchwork-Hint' => 'ignore');
}

sub mime_entity_to_mbox {
    my ($entity, $mbox_fh) = @_;

    for my $part ($entity->parts ? $entity->parts : ($entity)) {
	if ($part->as_string =~ /^From /m) {
	    # We have to use QP and escape this later.  The as_string
	    # method will take care of escaping everything else as
	    # needed for QP.
	    $part->head->replace('Content-Transfer-Encoding',
				 'quoted-printable');
	}
    }

    # Escape 'From ' within the message and ensure are at least two '\n'
    # before the 'From ' of the next message
    my $text = $entity->as_string;
    $text =~ s/^From /=46rom /gm;
    while ($text !~ /\n\n$/) {
	$text .= "\n";
    }

    # The address here will become the SMTP sender when using
    # formail + sendmail.  For now, copy the From address.  The date
    # is irrelevant though.
    my $sender = mailbox_addr_to_addr_spec($entity->head->get('From'));
    $mbox_fh->print("From $sender Mon Mar 25 00:00:00 2013\n");
    $mbox_fh->print($text);
}

sub print_signature {
    my ($out_fh) = @_;
    my $sig_fh = new FileHandle("${ENV{HOME}}/.signature", 'r');
    if (defined($sig_fh)) {
	print $out_fh "\n-- \n";
	while (<$sig_fh>) {
	    print $out_fh $_;
	}
	close($sig_fh);
    }
}

# Split mailbox address into name (if present) and addr-spec.
# Don't bother handling comments or rejecting all illegal characters.
sub parse_mailbox_addr {
    my ($mailbox) = @_;
    my ($name, $addr_spec);
    if ($mailbox =~ /^\s*((?:[^<]|\\.)*)\s*<([^<>]+)>\s*$/) {
	($name, $addr_spec) = ($1, $2);
	$name =~ s/\s*$//;
    } else {
	$addr_spec = $mailbox;
    }
    return ($name, $addr_spec);
}

sub mailbox_addr_to_addr_spec {
    return (parse_mailbox_addr(@_))[1];
}

# Make mailbox address from name (may be undef) and addr-spec.
sub make_mailbox_addr {
    my ($name, $addr_spec) = @_;
    if (!defined($name)) {
	return $addr_spec;
    } else {
	# Quote and MIMEify name as necessary
	if ($name !~ /^".*"$/) {
	    $name = "\"$name\"";
	}
	$name = MIME::Words::encode_mimewords($name, Charset => 'UTF-8');
	return "$name <$addr_spec>";
    }
}

# Split mailbox list into mailbox addresses.
# List is comma-separated, but addresses may also contain quoted or
# escaped commas.
sub parse_mailbox_list {
    my ($list) = @_;
    my (@mailboxes);
    while ($list =~ /\G((?:[^,\\\"]|\\.|"(?:[^,\\\"]|\\.)*")+),?/g) {
	push @mailboxes, $1;
    }
    return @mailboxes;
}

sub quilt_dir_from_git_dir {
    my ($git_dir) = @_;
    $git_dir = Cwd::abs_path($git_dir);
    for my $base (keys %STABLE_GIT) {
	if ($git_dir eq Cwd::abs_path($STABLE_GIT{$base})) {
	    return "$STABLE_QUEUES/queue-$base";
	}
    }
    return undef;
}

1;