#!/usr/bin/perl -Tw

############
##
## LCMDX.pm - Perl library providing convenience routines interfacing with lcmdx
##
############
## Copyright (c) 2004  Glue Logic LLC  All rights reserved  code()gluelogic.com
##
## This program is free software; you can redistribute it and/or
## modify it under the terms of the GNU General Public License
## as published by the Free Software Foundation; either version 2
## of the License, or (at your option) any later version.
##
## This program is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public License
## along with this program; if not, write to the
##   Free Software Foundation, Inc.
##   59 Temple Place - Suite 330
##   Boston, MA 02111-1307, USA
##
## Full text of the GNU General Public License may be found at:
##   http://www.gnu.org/copyleft/gpl.html
############
##
## This library is intended for use with a modified version of LSoft's
## lcmdx which can be found at http://www.gluelogic.com/code/LISTSERV/
##
## This library throws exceptions when an error is encountered,  so callers
## should wrap API calls in eval { } to catch them.  Caller should also set
## an alarm to interrupt commands that take too long to complete.
##
## Note that this library assumes a reasonable amount of memory.  Strings are
## slung freely; very little effort is expended to keep memory footprint small.
##
## NB:  Beware that untrusted users should not be able to submit
##      listhost, admin, or adminpw containing newlines!
##      Always check untrusted content carefully!
##
## This is a simple library that wraps the simple lcmdx program.
## If performance is the goal, you should bypass lcmdx entirely and speak
## directly to TCPGUI socket, to which you can send multiple commands on the
## same socket instead of suffering the lcmdx process creation overhead for
## each command.  See the LSoft Developer's Guide, which may be obtained at:
##   http://www.lsoft.com/resources/manuals.asp
##
## Examples:
##
##   $::ENV{'PATH'} = "/usr/local/bin:/bin:/usr/bin";  ## Perl taint safety
##   $|=1;
##
##   my $LISTHOST = 'lists.example.com';
##   my $ADMIN    = 'admin@example.com';
##   my $ADMINPW  = 'admin-listserv-pw';
##
## Set a header variable to a specific value
## (Caution: this example unconditionally sets the value,
##  even for multiple matches on multiple lines)
## (Modify the regex mapping at your own peril --
##  View and verify the resulting header before committing!)
##
##   my($list,$variable,$value)=@ARGV; ## e.g. @ARGV=('mylist','x-tags','Yes');
##
##   my $list_header = get_list_header_array($LISTHOST,$ADMIN,$ADMINPW,$list);
##   map { s/^(\*\s+\Q$variable\E)=.*/$1= $value/i } @$list_header;
##   my $response =
##     put_list_header_array($LISTHOST, $ADMIN, $ADMINPW, $list, $list_header);
##   print "\n",$$response,"\n";
## 
## Get temporary cookie id for use with X-LOGCK $logck_id WM: <command>
##   my $logck_id = get_logck_id($LISTHOST, $ADMIN, $ADMINPW);
##
############

package LCMDX;
$LCMDX::VERSION = 0.01;

use strict;
use Symbol ();
use IPC::Open3 ();

use constant LCMDX => '/usr/local/bin/lcmdx';

sub lcmdx {
    my($listhost, $admin, $adminpw, $command) = @_;
    ## (patched version of lcmdx.c always uppercases passwords; see)
    ##   http://www.gluelogic.com/code/LISTSERV/
    ##$adminpw = uc $adminpw;  ## password must be uppercase for TCPGUI commands
    local $::SIG{'PIPE'} = 'IGNORE';
    local $/ = undef;

    ## execute lcmdx
    my($wtr,$rdr,$err,$error,$pid,$response) =
      (Symbol::gensym, Symbol::gensym, Symbol::gensym, '');
    eval { $pid = IPC::Open3::open3($wtr, $rdr, $err, LCMDX,'-','-','-','-') }
      || (defined($@) && die("lcmdx: ".$@."\n")); ## IPC::Open3 threw exception

    ## send command and read response
    if (print $wtr $listhost,"\n",$admin,"\n",$adminpw,"\n",$$command) {
        close $wtr;
        $response = <$rdr>;
        close $rdr;
    }

    ## check for error writing or reading, or for message on error handle
    if ($!+0 != 0) {
        $error = "lcmdx: $!\n";
    }
    my $rd = '';
    vec($rd,fileno($err),1) = 1;
    if (scalar select($rd, undef, undef, 0)) {
        $error .= <$err>;
    }
    close $err;
    waitpid($pid, 0);
    if ($error ne '' || $? != 0) {
        $error .= "lcmdx: $!\n" unless ($error ne '' || $!+0 == 0);
        $error .= "lcmdx: $listhost $admin\nlcmdx: $$command\n";
        die $error;
    }

    return \$response;
}


sub get_logck_id {
    my($listhost, $admin, $adminpw) = @_;
    my $command = "x-login $admin";
    my $response = lcmdx($listhost, $admin, $adminpw, \$command);
    my($logck_id) = $$response =~ /^\*\*\*OK\*\*\* (\S+)/;
    defined($logck_id)
      ? $logck_id
      : die("lcmdx: x-login $admin: $$response\n");
}


sub get_list_header_array {
    ## read list header into array of header lines
    ## remove blank or empty lines at beginning and end of header
    ## ("REVIEW $list (MSG SHORT" can be used for some additional list info)
    my($listhost, $admin, $adminpw, $list) = @_;
    my $command  = "GET $list (MSG HEAD NOLOCK";
    my $response = lcmdx($listhost, $admin, $adminpw, \$command);
    my @list_header = split /\r?\n/s, $$response;
    shift @list_header if    ($list_header[0]             =~ /^PUT /);
    shift @list_header while ($list_header[0]             =~ /^\*?\s*$/);
    pop   @list_header while ($list_header[$#list_header] =~ /^\*?\s*$/);
    return \@list_header;
}


sub put_list_header_array {
    my($listhost, $admin, $adminpw, $list, $list_header) = @_;
    my $command = "X-STL $list ";
    $command   .= length($_).'_'.$_ foreach (@$list_header);
    return lcmdx($listhost, $admin, $adminpw, \$command);
}


1;