War Stories: Open Sesame

War Stories: Open Sesame

Given that most of our customers are already several years into development by the time they regard engaging a consultancy to help out as a suitable option, I've got to see all sorts of interesting things - and try and come up with ways to fix them.

In this case, there was a bunch of old code that did

open SENDMAIL, '|/usr/sbin/sendmail -oi -t';
print SENDMAIL $mail;
close SENDMAIL;

and, while the customer wanted to replace it, they also wanted to have some level of confidence that the replacement actually worked.

Which means we had to figure out a way to test it.

Round trip testing of email is ... possible, but OMG slow. Replacing the binary would maybe work out, but would require either a chroot or temporarily confusing your dev box (and then what if a cron job runs while you're using it ...).

So I decided to see if I could trap the open call, and after a fascinating journey down the rabbit hole ended up with -

package Hijack::Sendmail;

use strict;
use warnings;

our @Mail_Send;

# Lots of places do open("|sendmail ...") - right now we want to add tests with
# changing as little of the codebase as possible, so just trap those calls to
# open
BEGIN {
  my $maker = sub {
    my ($pkg) = @_;
    my $sub = eval 'sub {'."\n  package ${pkg};\n".'
    no strict q(refs);
    if (@_ == 1) {
        return CORE::open($_[0]);
    }
    elsif (@_ == 2) {
        return CORE::open($_[0], $_[1]);
    }
    elsif (@_ >= 3) {
        return CORE::open($_[0], $_[1], @_[2 .. $#_]);
    }
  }';
    die "Eval failed for ${pkg}: $@" unless $sub;
    return $sub;
  };
  my %opens;
  *CORE::GLOBAL::open = sub (*;$@) {
    my $caller = caller;
    #{ no warnings; warn "Hijacked open from $caller: @_"; }
    if (@_ > 1 and $_[1] =~ /^\|.*sendmail/) {
      my $send = '';
      push @Mail_Send, { args => [ @_[1..$#_] ], send => \$send };
      @_ = ($_[0], '>', \$send);
    }
    ($opens{$caller}||=$maker->($caller))->(@_);
  };
}

1;

Ok, so what's going on here? The innermost part is really just code to call CORE::open with our arguments -

if (@_ == 1) {
    return CORE::open($_[0]);
}
elsif (@_ == 2) {
    return CORE::open($_[0], $_[1]);
}
elsif (@_ >= 3) {
    return CORE::open($_[0], $_[1], @_[2 .. $#_]);
}

with multiple branches because on older perls, CORE::open's prototype is sufficiently deep magic that &CORE::open doesn't work (on 5.16+ it does).

This would be sufficient to propagate open calls on scalars, but won't handle

open SENDMAIL, ...

so we disable strict refs, and then eval a copy per package in order to have it qualify to The::Calling::Package::SENDMAIL rather than Hijack::Sendmail::SENDMAIL:

my $maker = sub {
  my ($pkg) = @_;
  my $sub = eval 'sub {'."\n  package ${pkg};\n".'
  no strict q(refs);
  if (@_ == 1) {
      return CORE::open($_[0]);
  }
  elsif (@_ == 2) {
      return CORE::open($_[0], $_[1]);
  }
  elsif (@_ >= 3) {
      return CORE::open($_[0], $_[1], @_[2 .. $#_]);
  }
}';
  die "Eval failed for ${pkg}: $@" unless $sub;
  return $sub;
};

Having built a re-call maker, we can now use it to pass calls on without altering their semantics -

my %opens;
*CORE::GLOBAL::open = sub (*;$@) {
  my $caller = caller;
  #{ no warnings; warn "Hijacked open from $caller: @_"; }
  ($opens{$caller}||=$maker->($caller))->(@_);
};

with %opens as a cache so e only do the eval once per calling package. The commented out line existed, of course, so I could uncomment it while I was figuring all this out since there was some fun WTF-ery in figuring out how to build the re-call maker sub.

Then all we need to do is detect calls to a pipe to sendmail (I'm only detecting 2-arg open here because, surprise surprise, that's all that was used in the legacy code) and rewrite them to a scalarref filehandle - i.e.

my %opens;
*CORE::GLOBAL::open = sub (*;$@) {
  my $caller = caller;
  #{ no warnings; warn "Hijacked open from $caller: @_"; }
  if (@_ > 1 and $_[1] =~ /^\|.*sendmail/) {
    my $send = '';
    push @Mail_Send, { args => [ @_[1..$#_] ], send => \$send };
    @_ = ($_[0], '>', \$send);
  }
  ($opens{$caller}||=$maker->($caller))->(@_);
};

makes (so long as you load Hijack::Open before the legacy code is compiled)

open SENDMAIL, '|/usr/sbin/sendmail';

behave as if it was actually

open SENDMAIL, '>', \$send;

at which point the output of the print statements goes into $send instead of down a pipe, and we end up with the mail-as-sent sat in @Mail_Send waiting for us to check it - so you can write something like

{
  local @Mail_Send;
  call_thing_that_sends_mail();
  is_deeply(\@Mail_Send, [ ... ], 'Emails sent as expected';
}

And then we could write tests for all of the existing sendmail calls, and my team and the customer's developers took great joy in ripping them all out and replacing them with CPAN modules.

I love a story with a happy ending.

-- mst, out.