tbmail.pm 4.56 KB
Newer Older
1 2 3
#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
Mike Hibler's avatar
Mike Hibler committed
4
# Copyright (c) 2000-2004, 2006 University of Utah and the Flux Group.
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55
# All rights reserved.
#

package tbmail;
use Exporter;
@ISA    = "Exporter";
@EXPORT = qw(makerecord parserecord printrecord sortrecords
	     REC_STAMP REC_PID REC_EID REC_UID REC_ACTION REC_MSGID REC_NODES
	     BAD IGNORE PRELOAD MODIFY MODIFYADD MODIFYSUB CREATE1 CREATE2
	     ISCREATE SWAPIN SWAPOUT SWAPOUTMAYBE TERMINATE BATCH BATCHIGNORE
	     BATCHCREATE BATCHCREATEMAYBE BATCHTERM BATCHTERMMAYBE BATCHSWAPIN
	     BATCHSWAPOUT BATCHPRELOAD ACTIONSTR
);

# Must come after package declaration!
use English;

# Load up the paths. Done like this in case init code is needed.
BEGIN
{
}

#
# Experiment records
# Record format is:
#	timestamp pid eid uid action msgid nodelist
#
sub REC_STAMP	{ return 0 };
sub REC_PID	{ return 1 };
sub REC_EID	{ return 2 };
sub REC_UID	{ return 3 };
sub REC_ACTION	{ return 4 };
sub REC_MSGID	{ return 5 };
sub REC_NODES	{ return 6 };

#
# Actions
#
sub BAD()	{ return 0 };
sub IGNORE()	{ return 1 };

sub PRELOAD()	{ return 2 };
sub MODIFY()	{ return 3 };
sub MODIFYADD()	{ return 4 };
sub MODIFYSUB()	{ return 5 };

sub CREATE1()	{ return 11 };	# 2000-ish creation message
sub CREATE2()	{ return 12 };	# 2001-ish creation message
sub ISCREATE($)
    { my $id = shift; return ($id && $id >= CREATE1 && $id <= CREATE2); }

Mike Hibler's avatar
Mike Hibler committed
56 57 58
sub SWAPIN()	    { return 21 };
sub SWAPOUT()	    { return 31 };
sub SWAPOUTMAYBE()  { return 32 };
59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178

sub TERMINATE()	{ return 41 };

sub BATCH()	       { return 50 };
sub BATCHIGNORE()      { return 51 };
sub BATCHCREATE()      { return 52 };
sub BATCHCREATEMAYBE() { return 53 };
sub BATCHTERM()	       { return 54 };
sub BATCHTERMMAYBE()   { return 55 };
sub BATCHSWAPIN()      { return 56 };
sub BATCHSWAPOUT()     { return 57 };
sub BATCHPRELOAD()     { return 58 };

my %actiontostr = (
    BAD()          => 'BAD',
    IGNORE()       => 'IGNORE',
    PRELOAD()      => 'PRELOAD',
    MODIFY()       => 'MODIFY',
    MODIFYADD()    => 'MODIFYADD',
    MODIFYSUB()    => 'MODIFYSUB',
    CREATE1()      => 'OCREATE',
    CREATE2()      => 'CREATE',
    SWAPIN()       => 'SWAPIN',
    SWAPOUT()      => 'SWAPOUT',
    TERMINATE()    => 'TERMINATE',
    BATCH()        => 'BATCH',
    BATCHCREATE()  => 'BATCHCREATE',
    BATCHTERM()    => 'BATCHTERM',
    BATCHSWAPIN()  => 'BATCHSWAPIN',
    BATCHSWAPOUT() => 'BATCHSWAPOUT',
);

my %strtoaction = (
    'BAD'         => BAD(),
    'IGNORE'      => IGNORE(),
    'PRELOAD'     => PRELOAD(),
    'MODIFY'      => MODIFY(),
    'MODIFYADD'   => MODIFYADD(),
    'MODIFYSUB'   => MODIFYSUB(),
    'OCREATE'     => CREATE1(),
    'CREATE'      => CREATE2(),
    'SWAPIN'      => SWAPIN(),
    'SWAPOUT'     => SWAPOUT(),
    'TERMINATE'   => TERMINATE(),
    'BATCH'       => BATCH(),
    'BATCHCREATE' => BATCHCREATE(),
    'BATCHTERM'   => BATCHTERM(),
    'BATCHSWAPIN' => BATCHSWAPIN(),
    'BATCHSWAPOUT'=> BATCHSWAPOUT(),
);

sub ACTIONSTR($) { my $a = shift; return $actiontostr{$a} };

#
# Make sure we create/consume records in a consistent way
#
sub makerecord($$$$$$@) {
    my ($stamp, $pid, $eid, $uid, $action, $msgid, @nodes) = @_;
    return [ $stamp, $pid, $eid, $uid, $action, $msgid, @nodes ];
}

sub parserecord($) {
    my $l = shift;
    my ($stamp, $pid, $eid, $uid, $action, $msgid, @nodes) = split(/\s+/, $l);
    $action = $strtoaction{$action};
    return undef if (!$action);
    return [ $stamp, $pid, $eid, $uid, $action, $msgid, @nodes ];
}

#
# Sort records: first by timestamp, then by pid/eid, uid, real/fake
#
sub recsort {
    return $a->[REC_STAMP] <=> $b->[REC_STAMP] ||
	$a->[REC_PID] cmp $b->[REC_PID] ||
	$a->[REC_EID] cmp $b->[REC_EID] ||
	$a->[REC_UID] cmp $b->[REC_UID] ||
	$a->[REC_MSGID] cmp $b->[REC_MSGID];
}
sub sortrecords(@) {
    return sort recsort @_;
}

#
# Sort nodes: pcs before sharks, then in numeric order
#
sub nodesort {
    # sort by name prefix
    my $as = $1 if ($a =~ /^(\D+)/);
    my $bs = $1 if ($b =~ /^(\D+)/);
    if (my $sc = $as cmp $bs) {
	return $sc;
    }

    # shark hack, take out '-'
    (my $an = $a) =~ s/-//;
    (my $bn = $b) =~ s/-//;

    # sort by number
    $an = $1 if ($an =~ /(\d+)$/);
    $bn = $1 if ($bn =~ /(\d+)$/);
    return $an <=> $bn if ($an && $bn);
    return $a cmp $b;
}

sub printrecord($$) {
    my ($rec, $sortem) = @_;
    my ($stamp, $pid, $eid, $uid, $action, $msgid, @nodes) = @{$rec};

    my $actstr = $actiontostr{$action};
    if ($sortem && @nodes > 1) {
	@nodes = sort nodesort @nodes;
    }

    print "$stamp $pid $eid $uid $actstr $msgid";
    if (@nodes > 0) {
	print " ", join(" ", @nodes);
    }
    print "\n";
}