[Tuxaator-commits] tuxaator/tuxaator3 XINI.pm, NONE, 1.1 prototux.pl, NONE, 1.1 tuxaator.ini, NONE, 1.1

[Andres S. <di...@us...>]

Update of /cvsroot/tuxaator/tuxaator/tuxaator3
In directory sc8-pr-cvs10.sourceforge.net:/tmp/cvs-serv10004

Added Files:
	XINI.pm prototux.pl tuxaator.ini 
Log Message:
initial import of Tuxaator 3

--- NEW FILE: prototux.pl ---
#! /usr/bin/perl -w

use strict;
use Net::IRC;
use XINI;
use POSIX ':sys_wait_h';

my $VERSION = '0.1';

my %SERVICES; # list of all currently active services
my @CHANNELS; # list of all currently active channels
my %RULES;

init_ini 'tuxaator.ini';

my $irc = new Net::IRC;
my $conn = $irc->newconn(Nick => ini 'general:nick',
                         Server => ini 'general:host',
                         Port => ini 'general:port = 6667',
                         Ircname => ini "general:ircname = ProtoTux/$VERSION");

{
    package Spawn;

    use strict;
    use IPC::Open2;
    use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);

    sub new ($$$) {
        my ($class, $command, $output_handler) = @_;
        my $this = {};

        $this->{command} = $command;
        $this->{output_handler} = $output_handler;

        my ($rdh, $wrh);
        my $pid = open2($rdh, $wrh, $command);
        my $flags = fcntl $rdh, F_GETFL, 0 or die "fcntl: F_GETFL: $!";
        fcntl $rdh, F_SETFL, $flags | O_NONBLOCK or die "fcntl: F_SETFL: $!";

        $this->{pid} = $pid;
        $this->{stdout} = $rdh;
        $this->{stdin} = $wrh;
        $this->{input_end} = 0;
        $this->{in_queue} = '';
        $this->{out_queue} = '';
        $this->{selecting_input} = 0;

        $irc->addfh($this->{stdout}, sub {$this->process_output}, 'r');

        return bless $this, $class;
    }

    sub process_input ($) {
        my ($this) = @_;

        return unless defined $this->{stdin};

        my $result = 1;
        while ($result) {
            last if $this->{in_queue} eq '';
            $result = syswrite($this->{stdin}, $this->{in_queue},
                               length $this->{in_queue}, 0);
            goto CLOSE_DOWN if $!{EPIPE};
            die "write to service: $!\n"
                unless defined $result or $!{EAGAIN};
            substr($this->{in_queue}, 0, $result) = ''
                if defined $result;
        }
        if ($this->{in_queue} ne '' and !$this->{selecting_input}) {
            $irc->addfh($this->{stdin}, sub {$this->process_input}, 'w');
            $this->{selecting_input} = 1;
        }
        if ($this->{in_queue} eq '' and $this->{selecting_input}) {
            $irc->removefh($this->{stdin});
            $this->{selecting_input} = 0;
        }
        if ($this->{input_end} and $this->{in_queue} eq '') {
CLOSE_DOWN:
            $irc->removefh($this->{stdin}) if $this->{selecting_input};
            close $this->{stdin};
            $this->{stdin} = undef;
            $this->{in_queue} = undef;
        }
        return;
    }

    sub process_output ($) {
        my ($this) = @_;

        my $result;
        do {
            $result = sysread($this->{stdout}, $this->{out_queue},
                              1024, length $this->{out_queue});
            die "read from service: $! (@{[%!]})"
                unless defined $result or $!{EAGAIN};
        } while ($result);
        if (defined $result and $result == 0) {
            $irc->removefh($this->{stdout});
            close $this->{stdout};
            $this->{stdout} = undef;
            $this->{out_queue} =~ s/([^\n])$/$1\n/s;
        }
        my $interpreter = $this->{output_interpreter};
        while ($this->{out_queue} =~ s/^(.*?)\r?\n//s) {
            &{$this->{output_handler}}($1);
        }
        return;
    }

    sub write ($$) {
        my ($this, $data) = @_;

        $this->{in_queue} .= $data if defined $this->{stdin};
        return;
    }

    sub close_input ($) {
        my ($this) = @_;

        $this->{input_end} = 1;
        $this->process_input;
        return;
    }
}

{
    package Service;

    use strict;
    use IPC::Open2;
    use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
    use MIME::Base64;
    use XINI;

    sub new ($$) {
        my ($class, $name) = @_;
        my $this = {};

        my $type = lc ini "service $name:type=daemon";

        if ($type eq 'daemon') {
            $this->{spawn} = new Spawn ini "service $name:command", sub {
                my ($line) = @_;
                my $interpreter = $this->{output_interpreter};
                $this->$interpreter($line);
            };
        } elsif ($type eq 'invoke') {
            $this->{command} = ini "service $name:command";
        } else {
            die "unknown service type '$type' for '$name'";
        }
        $this->{type} = $type;

        my $format_input = ini "service $name:format input=complex";
        if ($format_input =~ m/^complex$/i) {
            $this->{input_formatter} = 'format_complex';
        } elsif ($format_input =~ m/^table:\s*(.*)$/i) {
            $this->{input_fields} = [map {"event_field_$_"} split /\s+/, lc $1];
            my %known_fields = map {("event_field_$_" => 1)} qw(type from to nick userhost args time gmtime localtime context);
            for my $field (@{$this->{input_fields}}) {
                die "unknown field '$field' in [service $name]format input"
                    unless exists $known_fields{$field};
            }
            $this->{input_formatter} = 'format_tabs';
            my $separator;
            if (ini_got "service $name:column separator") {
                $separator = ini "service $name:column separator";
                $separator = ' ' if $separator eq '';
            } else {
                $separator = "\t";
            }
            $this->{column_separator} = $separator;
        } else {
            die "unknown value [service $name]format input = $format_input";
        }

        my $interpret_output = ini "service $name:interpret output=stateless commands";
        if ($interpret_output =~ m/^stateless\s+commands$/i) {
            $this->{output_interpreter} = 'stateless_commands';
        } else {
            die "unknown value [service $name]interpret output = $interpret_output";
        }

        return bless $this, $class;
    }

    sub enter ($$) {
        my ($this, $event) = @_;

        $this->handle($event) if $this->{main_rule}->matches($event);
        return;
    }

    sub handle ($$) {
        my ($this, $event) = @_;

        my $format = $this->{input_formatter};
        my $data = $this->$format($event);

        if ($this->{type} eq 'daemon') {
            $this->{spawn}->write("$data\n");
        } elsif ($this->{type} eq 'invoke') {
            my $context = $this->event_field_context($event);
            my $spawn = new Spawn $this->{command}, sub {
                my ($line) = @_;
                $conn->privmsg($context, $line);
            };
            $spawn->write("$data\n");
            $spawn->close_input;
        }
        return;
    }

    sub format_complex ($$) {
        my ($this, $event) = @_;

        my $line = $event->type;
        $line .= " from:" . encode_base64($event->from, "");
        $line .= " to:" . join(',', map {encode_base64($_, "")} $event->to);
        $line .= " nick:" . encode_base64($event->nick, "");
        $line .= " userhost:" . encode_base64($event->userhost, "");
        $line .= " args:" . join(',', map {encode_base64($_, "")} $event->args);
        return $line;
    }

    sub event_field_type ($$) {
        my ($this, $event) = @_;

        return $event->type;
    }

    sub event_field_from ($$) {
        my ($this, $event) = @_;

        return $event->from;
    }

    sub event_field_to ($$) {
        my ($this, $event) = @_;

        return $event->to;
    }

    sub event_field_nick ($$) {
        my ($this, $event) = @_;

        return $event->nick;
    }

    sub event_field_userhost ($$) {
        my ($this, $event) = @_;

        return $event->userhost;
    }

    sub event_field_args ($$) {
        my ($this, $event) = @_;

        return $event->args;
    }

    sub event_field_time ($$) {
        return time;
    }

    sub event_field_localtime ($$) {
        return scalar localtime;
    }

    sub event_field_gmtime ($$) {
        return scalar gmtime;
    }

    sub event_field_context ($$) {
        my ($this, $event) = @_;
        my $type = $event->type;
        if ($type eq 'public') {
            return join(",", $event->to);
        } else {
            return $event->nick;
        }
    }

    sub format_tabs ($$) {
        my ($this, $event) = @_;
        my @items;
        for my $field (@{$this->{input_fields}}) {
            my @data = $this->$field($event);
            push @items, join(' ', @data);
        }
        return join $this->{column_separator}, @items;
    }

    sub stateless_commands ($$) {
        my ($this, $command) = @_;
        if ($command =~ m/^\/say\s+(.*)$/si) {
            for my $channel (@CHANNELS) {
                $conn->privmsg($channel, $1);
            }
        } elsif ($command =~ m/^\/msg\s+(\S+)\s+(.*)$/si) {
            my $msg = $2;
            for my $dest (split /,/, $1) {
                $conn->privmsg($dest, $msg);
            }
        } else {
            warn "Service $this->{name} issued weird stateless command \"$command\".\n";
        }
    }
}

{
    package Rule;

    use strict;
    use XINI;

    sub new ($$) {
        my ($class, $name) = @_;
        my $this = {};
        my ($rdh, $wrh);

        my ($section, $service);
        if ($name =~ m/^\[\s*(service (.*?))\s*\]$/) {
            $section = $1;
            $service = $2;
        } else {
            $section = "rule $name";
            $service = ini "rule $name:service";
        }
        $this->{section} = $section;
        die "No service '$service' (required for rule '$name')"
            unless exists $SERVICES{$service};

        $this->{name} = $name;
        $this->{service} = $SERVICES{$service};

        if (ini_got "$this->{section}:events") {
            $this->{events} = {map {($_ => 1)} split /\s+/, lc ini "$this->{section}:events"};
        }

        if (ini_got "$this->{section}:requests") {
            $this->{requests} = {map {($_ => 1)} split /\s+/, ini "$this->{section}:requests"};
        }

        return bless $this, $class;
    }

    sub matches ($$) {
        my ($this, $event) = @_;

        # Is the event type right?
        if (exists $this->{events}) {
            #print "Checking type (is ".$event->type.", requiring @{[keys %{$this->{events}}]})\n";
            return 0 unless exists $this->{events}->{$event->type};
        }

        # Is the request prefix right?
        if (exists $this->{requests}) {
            my ($request, $args) = split /\s+/, join(' ', $event->args), 2;
            return 0 unless exists $this->{requests}->{$request};
        }
        return 1;
    }

    sub enter ($$) {
        my ($this, $event) = @_;

        print "$this->{name} entered event; matches => ".$this->matches($event)."\n";
        $this->{service}->handle($event) if $this->matches($event);
        return;
    }
}

@CHANNELS = split /\s+/, ini 'general:channels = #prototux';

for my $name (ini_sections 'service *') {
    my $service = new Service $name;
    $SERVICES{$name} = $service;
    $service->{main_rule} = new Rule "[service $name]";
}

for my $name (ini_sections 'rule *') {
    my $rule = new Rule $name;
    $RULES{$name} = $rule;
}

my $active = 0;

sub on_irc_event {
    my ($this, $event) = @_;
    if ($event->type eq 'endofmotd') {
        for my $channel (@CHANNELS) {
            $this->join($channel);
        }
        $active = 1;
    }
    if ($active) {
        for my $handler (values %SERVICES, values %RULES) {
            $handler->enter($event);
        }
    }
    return;
}

$SIG{CHLD} = sub {
    while (1) {
        my $pid = waitpid -1, WNOHANG;
        last if $pid <= 0;
    }
};

$SIG{PIPE} = 'IGNORE';

$conn->add_default_handler(\&on_irc_event);

my @types = qw(nick quit join part mode topic kick public msg notice ping other invite kill disconnect leaving umode error cping cversion csource ctime cdcc cuserinfo cclientinfo cerrmsg cfinger caction crping crversion crsource crtime cruserinfo crclientinfo crfinger dcc_open dcc_update dcc_close chat 251 252 253 254 302 255 376 433 353);

$conn->add_global_handler(\@types, \&on_irc_event);
$conn->add_handler(\@types, \&on_irc_event);

$irc->start;

--- NEW FILE: tuxaator.ini ---
[general]
host = irc.estpak.ee
nick = tux]I[tor
channels = #linux.ee

[service clock]
type = invoke
command = date +%H:%M
events = public msg
requests = !clock !kell

[service tm]
type = invoke
command = perl -e 'my $t = time; print $t, " = ", scalar localtime $t'
events = public msg
requests = !tm

--- NEW FILE: XINI.pm ---
#### XINI.pm - eXtended INI file handling

package XINI;
push @::VERSIONS, '$Id: XINI.pm,v 1.1 2006/07/11 21:46:18 digg Exp $';

use strict;
use Carp;
require Exporter;
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw(init_ini merge_ini ini ini_got ini_sections
             ini_either ini_combine ini_push ini_pop ini_raw
             ini_inheritance ini_age);

my $inihash = undef;
my @inifilenames;
my @inistack; # current section stack

sub parse_ini ($$@) {
    my ($shr, $filename, @lines) = @_;
    my ($csn, $khr) = undef;
    my %seen; # per-file
    for my $i (0 ... $#lines) {
        my $line = $lines[$i];
        chomp $line;
        if ($line =~ m/^\s*;/ or $line =~ m/^\s*$/) {
            # do nothing
        } elsif ($line =~ m/^\s*\[\s*(.*?)\s*\]\s*$/) {
            $csn = $1;
            croak "$filename:".($i + 1).": empty section name, aborting"
                if $csn =~ m/^\s*$/;
            croak "$filename:".($i + 1).": invalid section name, aborting"
                if $csn =~ m/[\$:=]/;
            croak "$filename:".($i + 1).": duplicate section name [$csn], aborting"
                if exists $seen{"$csn:"};
            $seen{"$csn:"} = 1;
            $shr->{$csn} = {} unless exists $shr->{$csn};
            $khr = $shr->{$csn};
        } elsif ($line =~ m/^\s*([^=]*?)\s*=\s*(.*)$/) {
            my ($key, $value) = ($1, $2);
            croak "$filename:".($i + 1).": key outside section, aborting"
                unless defined $khr;
            croak "$filename:".($i + 1).": empty key name, aborting"
                if $key =~ m/^\s*$/;
            croak "$filename:".($i + 1).": invalid key name, aborting"
                if $key =~ m/[:=]/;
            croak "$filename:".($i + 1).": duplicate key [$csn]$key, aborting"
                if exists $seen{"$csn:$key"};
            $seen{"$csn:$key"} = 1;
            $khr->{$key} = $value;
        } else {
            croak "$filename:".($i + 1).": ini parse error, aborting";
        }
    }
}

sub init_ini (@) {
    my (@filenames) = @_;

    my %ini;
    $inihash = \%ini;
    for my $filename (reverse @filenames) {
        my $fh;
        open $fh, '<', $filename or die "$filename: open for reading: $!";
        my @lines = <$fh>;
        close $fh;
        $lines[0] =~ s/^\xEF\xBB\xBF// if @lines; # drop the BOM
        s/\x0D?\x0A?$// for @lines;
        parse_ini $inihash, $filename, @lines;
    }
    @inifilenames = @filenames;
}

sub merge_ini ($) {
    my ($filename) = @_;

    unshift @inifilenames, $filename;
    init_ini @inifilenames;
}

# return the ancestry list, from eldest to to the mentioned section
sub ini_inheritance ($)
{
    my ($child) = @_;
    my @ancestry = ($child);
    while (1)
      {
        die "no [$ancestry[0]]" unless exists $inihash->{$ancestry[0]};
        return @ancestry unless exists $inihash->{$ancestry[0]}{'.'};
        unshift @ancestry, $inihash->{$ancestry[0]}{'.'};
      }
}

# get a single ini item, taking care of inheritance
sub ini_raw ($$) {
    my ($section, $key) = @_;
    my %visited;
AGAIN:
    return undef unless exists $inihash->{$section};
    return $inihash->{$section}{$key} if exists $inihash->{$section}{$key};
    return undef unless exists $inihash->{$section}{'.'};
    $visited{$section} = 1;
    $section = $inihash->{$section}{'.'};
    die "inheritance loop involving [$section] detected"
        if exists $visited{$section};
    goto AGAIN;
}

# Determine the generation count of $key in its section ancestry.
# If [$section]$key is found, the age is 1.
# If such $key is not found at all, returns undef.
sub ini_age ($$) {
    my ($section, $key) = @_;
    my %visited;
    my $age = 1;
AGAIN:
    return undef unless exists $inihash->{$section};
    return $age if exists $inihash->{$section}{$key};
    return undef unless exists $inihash->{$section}{'.'};
    $visited{$section} = 1;
    $section = $inihash->{$section}{'.'};
    die "inheritance loop involving [$section] detected"
        if exists $visited{$section};
    $age++;
    goto AGAIN;
}

# get list of keys in a section, taking care of inheritance
sub _ini_get_section_keys ($) {
    my ($section) = @_;
    my %visited;
    my %keys;

    while (exists $inihash->{$section}) {
        %keys = (%keys, %{$inihash->{$section}});
        last unless exists $inihash->{$section}{'.'};
        $visited{$section} = 1;
        $section = $inihash->{$section}{'.'};
        die "inheritance loop involving [$section] detected"
            if exists $visited{$section};
    }
    delete $keys{'.'};
    my @keys = sort keys %keys;
    return @keys;
}

sub _expand_var ($$) {
    my ($section, $var) = @_;
    my @sectcomp = split /\s+/, $section;
    for my $sec ($section, '$') {
        my $exp = ini_raw $sec, '$('.$var.')';
        return $exp if defined $exp;
        $exp = ini_raw $sec, '$'.$var;
        return $exp if defined $exp;
    }
    return undef;
}

# Get an ini entry.
sub ini ($) {
    my ($request) = @_;

    my ($section, $key, $mode, $default);
    if ($request =~ m/^([^\[\]=:]*?):([^\[\]=:]*?)(?:\s*(:?=)\s*(.*))?$/)
        {($section, $key, $mode, $default) = ($1, $2, $3, $4)}
    else {croak "Invalid INI request: $request"}
    if ($section eq '') {
        croak "indecisive INI request $request"
            unless @inistack;
        $section = $inistack[-1];
    }
    if (defined $mode and $mode eq ':=') {
        croak "incomplete INI change request $request"
            unless defined $section and defined $key and defined $default;
        croak "No section [$section]"
            unless exists $inihash->{$section};
        $inihash->{$section}{$key} = $default;
        return $default;
    }
    if ($key eq '' or $key =~ m/\*/ and $key !~ m/\(no star\)$/) {
        # no key given or key is mask
        croak "No section [$section]"
            unless exists $inihash->{$section};
        my @keys = _ini_get_section_keys $section;
        if ($key eq '') {
            @keys = sort grep !/^\$/, @keys;
        } else {
            my @keychars = split //, $key;
            @keychars = map {
                if ($_ eq '*') {'.*'} else {s/(\W)/\\$1/; $_}
            } @keychars;
            my $keyre = join '', @keychars;
            @keys = sort grep /^$keyre$/, @keys;
        }
        return @keys if wantarray;
        return join ' ', @keys;
    }
    $key =~ s/\s*\(no star\)$//;
    my $value = ini_raw $section, $key;
    unless (defined $value) {
        if (defined $default) {$value = $default}
        else {croak "No [$section]$key in (@inifilenames)"}
    }
    $value = [$value] unless ref $value eq 'ARRAY';
    my @results = map {
        my $value = $_;
        my $limit = 100; # avoid infinite recursion
        my $last_value;
        do {
            croak "Too deep recursion in [$section]$key"
                if --$limit == 0;
            $last_value = $value;
            $value =~ s{(\$([\w-]+\b))}{my $x = _expand_var($section, $2); defined $x ? $x : $1}ge;
            $value =~ s{(\$\(([\w-]+):([\w-]+)\))}{my $x = _expand_var($2, $3); defined $x ? $x : $1}ge;
            croak "Too long expansion for [$section]$key"
                if length $value > 65536;
        } while $value ne $last_value;
        $value;
    } @$value;
    return $results[0] if @results == 1;
    return \@results;
}

# Checks existence of a specified INI part.
# No flags, colonized interface:
# foo:bar - key 'bar' in section 'foo'
# foo:    - section 'foo'
#    :bar - key 'bar' in current section
sub ini_got ($) {
    my ($request) = @_;

    my ($section, $key, $default);
    if ($request =~ m/^([^\[\]=:]*):([^\[\]=:]*)$/)
        {($section, $key) = ($1, $2)}
    else {croak "Invalid INI request: $request"}
    croak "content-free argument to ini_got"
        if $section eq '' and $key eq '';
    if ($section eq '') {
        croak "indecisive INI request $request"
            unless @inistack;
        $section = $inistack[-1];
    }
    return exists $inihash->{$section} if $key eq '';
    return defined ini_raw $section, $key;
}

sub ini_sections (;$) {
    my ($mask) = @_;
    my @sections = keys %$inihash;
    if (defined $mask) {
        croak "invalid ini section mask '$mask'"
            unless $mask =~ m/^[^*]*\*[^*]*$/;
        $mask =~ s/([^\w*])/\\$1/g;
        $mask =~ s/\*/(.*)/;
        @sections = map {m/^$mask$/} @sections;
    }
    return @sections
}

sub ini_either ($) {
    my ($spec) = @_;
    croak "invalid ini_either spec: $spec"
        unless my ($sections, $key) = $spec =~ m/^([^\[\]:]+):([^\[\]:=]+)$/;
    my @sections = split /=/, $sections;
    my $result = undef;
    my $result_bang = undef;
    my @gots = ();
    my @gots_bang = ();
    for my $sec (@sections) {
        if (ini_got "$sec\:$key") {
            $result = ini "$sec\:$key";
            push @gots, $sec;
        }
        if (ini_got "$sec\:$key!") {
            $result_bang = ini "$sec\:$key!";
            push @gots_bang, $sec;
        }
    }
    croak "precedence conflict between (".(join '=', @gots_bang).":$key!)"
        if @gots_bang > 1;
    return $result_bang
        if @gots_bang == 1;
    croak "precedence conflict between (".(join '=', @gots).":$key)"
        if @gots > 1;
    return $result
        if @gots == 1;
    croak "neither of $spec defined"
        unless @gots;
}

sub ini_combine (@) {
    my @sections = @_;
    my %result;
    my $sections = join '=', @sections;
    for my $sec (@sections) {
        croak "invalid section name: $sec"
            unless $sec =~ m/^[^\[\]=:]+$/;
        next unless ini_got "$sec\:";
        for my $k (ini "$sec\:") {
            next if $k =~ /!$/;
            $result{$k} = ini_either "$sections\:$k";
        }
    }
    return %result;
}

sub ini_push ($) {
    my ($section) = @_;
    croak "unable to push nonexistent section [$section]"
        unless exists $inihash->{$section};
    push @inistack, $section;
}

sub ini_pop () {
    croak "can't pop empty INI section stack"
        unless @inistack;
    pop @inistack;
}

1;