# for thekestrel
#!/usr/bin/perl

use strict;
use warnings;

use Data::Dumper;
use Parse::RecDescent;

my $grammar =<<'GRAMMAR';

        IDENTIFIER      : /\w+/ { [@item] }
        LITERAL         : /\d+/ { [@item] }
        SEP             : /;/   { [@item] }

        parse           : statement(s)
        statement       : call
                        | SEP

        call            : IDENTIFIER '(' LITERAL ')'
                        { [ @item[0, 1, 3] ] }

GRAMMAR

my $parser = Parse::RecDescent->new($grammar);

my $text = <<'DATA';
func(4);foo(1);
DATA

my $lang = Language::C->new();
my $result = $parser->parse($text);

for my $item ( @$result ) {
        print "Trying item : $item->[0]\n";
        my $method = $item->[0];
        $lang->$method(@$item);
}

package Language::C;

use vars '$AUTOLOAD';
sub new {bless {}, shift; }
sub AUTOLOAD {  print "$AUTOLOAD Bugger!\n" . Data::Dumper::Dumper(\@_
+); }
sub SEP { return }
#sub DESTROY { return }
sub call { print "Doing a call\n", Data::Dumper::Dumper(\@_); }
[download]

HTTP monitor code

# For smullis



package Monitor;

use strict;
use IO::Socket::INET;
use vars qw ( @ISA @EXPORT_OK $VERSION );
$VERSION = "0.03";

require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(
    test_port_simple
    test_port_detailed
);

# testing on port 25 requires sending (your) valid maildomain
my $MAILDOMAIN = 'hotmail.com';

sub test_port_simple {
    my ( $server, $port, $timeout, $verbose ) = @_;
  return "ERR - No server supplied" unless $server;
  return "ERR - No port supplied" unless $port;
    $timeout ||= 10;
    print "Simple testing $server:$port\n" if $verbose;
    my $sock = IO::Socket::INET->new( PeerAddr => $server,
                                      PeerPort => $port,
                                      Proto    => 'tcp',
                                      Timeout  => $timeout,
                                      ReuseAddr=>1,
                                      #ReusePort=>1,
    );
    my $res = $sock ? 'OK' : "ERR - Could not connect socket on port $
+port";
    $sock->close() if $sock;
    undef $sock;
  return $res;
}

sub test_port_detailed {
    my ( $server, $port, $timeout, $verbose ) = @_;
  return "ERR - No server supplied" unless $server;
  return "ERR - No port supplied" unless $port;
    $timeout ||= 10;
    print "Detail testing $server:$port\n" if $verbose;
    my $sock = IO::Socket::INET->new( PeerAddr => $server,
                                      PeerPort => $port,
                                      Proto    => 'tcp',
                                      Timeout  => $timeout,
                                      ReuseAddr=>1,
                                      #ReusePort=>1,
    );
    unless ( $sock ) {
        undef $sock;
      return "ERR - Could not connect socket on port $port";
    }

    my $errors = '';
    # OK so we have a socket but can we use it as expected
    # depending on the protocol we apply different tests....
    if ( $port == 21 ) {
        my $server = <$sock>;
        if ( $server ) {
            print $sock "USER anonymous\015\012";
            $server = <$sock>;
            $errors .= "No USER response from FTP server\n" unless $se
+rver;
            print $sock "QUIT\015\012";
        }
        else {
            $errors .= "No handshake sent from FTP server\n";
        }
    }
    elsif ( $port == 22 ) {
        my $server = <$sock>;
        if ( $server ) {
            # the server expects a string back or logs errors
            # echoing its ID string back shuts up the logs - stealth s
+can ;-)
            print $sock $server;
        }
        else {
            $errors .= "No handshake sent from SSH server\n";
        }
    }
    elsif ( $port == 25 ) {
        my $server = <$sock>;
        if ( $server ) {
            print $sock "HELO $MAILDOMAIN\015\012";
            $server = <$sock>;
            $errors .= "No HELO response from SMTP server\n" unless $s
+erver and $server =~ m/^250/;
            print $sock "QUIT\015\012";
        }
        else {
            $errors .= "No handshake sent from SMTP server\n"
        }
    }
    elsif ( $port == 80 ) {
        print $sock "GET / HTTP/1.0\015\012\015\012";
        my $server = <$sock>;
        $errors .= "Unexpected response from HTTP server: $server\n" u
+nless $server and $server =~ m/^HTTP/;
    }
    elsif ( $port == 110 ) {
        my $server = <$sock>;
        if ( $server ) {
            $errors .= "No OK sent by POP3 server\n" unless $server =~
+ m/OK/i;
            print $sock "USER nobody\015\012";
            $server = <$sock>;
            print $sock "PASS wrong_password\015\012";
            $server = <$sock>;
            $errors .= "Failed to get expected ERR response\n" unless 
+$server and $server =~ m/ERR/i;
            print $sock "QUIT\015\012";
        }
        else {
            $errors .= "No handshake sent from POP3 server\n";
        }
    }
    elsif ( $port == 3128 ) {
        print $sock "GET http://$server/ HTTP/1.0\015\012\015\012";
        my $server = <$sock>;
        $errors .= "Unexpected response from SQUID PROXY server\n" unl
+ess $server and $server =~ m/^HTTP/i;
    }
    else {
        # we don't have a detail test but do have a socket so this is 
+a NOP
    }
    $sock->close();
  return $errors ? "ERR - $errors" : 'OK';
}
[download]

#!/usr/bin/perl -w

$|++;
use strict;
use Fcntl;
use POSIX qw(setsid);
my ($PROGRAM) = $0 =~ m!([^\\/:]+)$!;
my $LOCKFILE = "/var/lock/$PROGRAM";
my $LOG      = "/var/log/$PROGRAM.error.log";


# use a lockfile to prevent spawning duplicate processes
unless ( sysopen(my $fh, $LOCKFILE, O_CREAT | O_EXCL | O_RDWR, 0600) )
+ {
    # the lockfile already exists
    print "Lockfile $LOCKFILE aready exists.\nChecking for running $PR
+OGRAM process...";
    my @ps = grep{ m/\Q$PROGRAM\E/ } `ps -C $PROGRAM`;
    # we expect 1 copy (us) running
    # print "@ps\n";
    die "\nThere is already a copy of $PROGRAM running!\n" if @ps > 1;
    print "None!\n";
}

# now demonize it

defined(my $pid = fork)   or die "Can't fork: $!";
exit 0 if $pid;

chdir '/'                 or die "Can't chdir to /: $!";
umask 0;
setsid()                  or die "Can't start a new session: $!";

$SIG{INT} = $SIG{TERM} = sub { 
    unlink $LOCKFILE or warn "Could not unlink $LOCKFILE for $PROGRAM\
+n"; 
    exit; 
};

$SIG{HUP} = sub { 
    warn "Caught HUP " . time() . "\n"; 
    # do reset stuff if required
};

print "Started $0 daemon OK\n\n";

open STDIN, '/dev/null'   or die "Can't read /dev/null: $!";
open STDOUT, '>/dev/null' or die "Can't write to /dev/null: $!";
#open STDERR, '>/dev/null' or die "Can't write to /dev/null: $!";
open STDERR, ">>$LOG" or die "Can't write to $LOG: $!";


# this is the main loop that runs forever, once every 30 seconds

while (1) {
    eval{ ... };   # use eval to exec any code so if it chokes the dae
+mon survives
    warn "$@\n" if $@;
    sleep 30;
}
[download]