#!/usr/bin/perl

#
# ferm, a firewall setup program that makes firewall rules easy!
#
# Copyright (C) 2001-2007 Auke Kok, Max Kellermann
#
# Comments, questions, greetings and additions to this program
# may be sent to <ferm@foo-projects.org>
#

#
# 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
#

# $Id: ferm 985 2007-12-08 23:35:29Z max $

BEGIN {
    eval { require strict; import strict; };
    $has_strict = not $@;
    if ($@) {
        # we need no vars.pm if there is not even strict.pm
        $INC{'vars.pm'} = 1;
        *vars::import = sub {};
    } else {
        require IO::Handle;
    }

    eval { require Getopt::Long; import Getopt::Long; };
    $has_getopt = not $@;
}

use vars qw($has_strict $has_getopt);

use vars qw($DATE $VERSION);

# subversion keyword magic
$DATE = '$Date: 2007-12-09 00:35:29 +0100 (Sun, 09 Dec 2007) $' =~ m,(\d{4})-(\d\d)-(\d\d), ? $1.$2.$3 : '';

$VERSION = '1.3.1';
#$VERSION .= '~svn' . $DATE;

## interface variables
# %option = command line and other options
use vars qw(%option);

## hooks
use vars qw(@pre_hooks @post_hooks);

## parser variables
# $script: current script file
# %oldvars = ferm 1.1 compatibility variables, name => value
# @stack = ferm's parser stack containing local variables
# $auto_chain = index for the next auto-generated chain
use vars qw($script %oldvars %rules @stack $auto_chain);

## netfilter variables
# %domains = state information about all domains ("ip" and "ip6")
# - initialized: domain initialization is done
# - tools: hash providing the paths of the domain's tools
# - previous: save file of the previous ruleset, for rollback
# - reset: has this domain already been reset?
# - tables{$name}: ferm state information about tables
#   - chains{$chain}: ferm state information about the chains
#     - builtin: whether this is a built-in chain
#     - was_created: custom chain has been created
#     - non_empty: are there rules for this chain?
use vars qw(%domains);

## constants
use vars qw(%deprecated_keywords %automod);

# keywords from ferm 1.1 which are deprecated, and the new one; these
# are automatically replaced, and a warning is printed
%deprecated_keywords = ( macsource => 'mac-source',
                         mac => 'mac-source',
                         settos => 'set-tos',
                         ttlset => 'ttl-set',
                         ttldec => 'ttl-dec',
                         ttlinc => 'ttl-inc',
                         pkttype => 'pkt-type',
                         uid => 'uid-owner',
                         uidowner => 'uid-owner',
                         gid => 'gid-owner',
                         gidowner => 'gid-owner',
                         pid => 'pid-owner',
                         pidowner => 'pid-owner',
                         sid => 'sid-owner',
                         sidowner => 'sid-owner',
                         ttleq => 'ttl-eq',
                         ttllt => 'ttl-lt',
                         ttlgt => 'ttl-gt',
                         loglev => 'log-level',
                         logprefix => 'log-prefix',
                         logseq => 'log-tcp-sequence',
                         logtcpopt => 'log-tcp-options',
                         logipopt => 'log-ip-options',
                         setmark => 'set-mark',
                         toports => 'to-ports',
                         rejectwith => 'reject-with',
                         tosrc => 'to-source',
                         todest => 'to-destination',
                         burst => 'limit-burst',
                         limitburst => 'limit-burst',
                         match => 'module',
                         frag => 'fragment',
                         'out-interface' => 'outerface',
                         icmptype => 'icmp-type',
                         tcpflags => 'tcp-flags',
                         tcpoption => 'tcp-option',
                         iplimitabove => 'iplimit-above',
                         iplimitmask => 'iplimit-mask',
                         'ip-limit-above' => 'iplimit-above',
                         'ip-limit-mask' => 'iplimit-mask',
                         psdweightthreshold => 'psd-weight-threshold',
                         psddelaythreshold => 'psd-delay-threshold',
                         psdloportsweight => 'psd-lo-ports-weight',
                         psdhiportsweight => 'psd-hi-ports-weight',
                         deny => 'DROP',
                         DENY => 'DROP',
                         MASQ => 'MASQUERADE',
                         masq => 'MASQUERADE',
                         masquerade => 'MASQUERADE',
                         accept => 'ACCEPT',
                         drop => 'DROP',
                         return => 'RETURN',
                         queue => 'QUEUE',
                         balance => 'BALANCE',
                         dnat => 'DNAT',
                         mirror => 'MIRROR',
                         redirect => 'REDIRECT',
                         reject => 'REJECT',
                         snat => 'SNAT',
                         tcpmss => 'TCPMSS',
                         ttl => 'TTL',
                         ulog => 'ULOG',
                         nop => 'NOP',
                         goto => 'jump',
                       );

# support for the deprecated "automod" option. provide a mapping
# between keywords and modules required for that
%automod = ( tos => 'tos',
             mark => 'mark',
             'mac-source' => 'mac',
             limit => 'limit',
             'limit-burst' => 'limit',
             'iplimit-above' => 'iplimit',
             'iplimit-mask' => 'iplimit',
             'uid-owner' => 'owner',
             'gid-owner' => 'owner',
             'pid-owner' => 'owner',
             'sid-owner' => 'owner',
             'psd-weight-threshold' => 'psd',
             'psd-delay-threshold' => 'psd',
             'psd-lo-ports-weight' => 'psd',
             'psd-hi-ports-weight' => 'psd',
             length => 'length',
             average => 'random',
             every => 'nth',
             counter => 'nth',
             start => 'nth',
             packet => 'nth',
             'pkt-type' => 'pkttype',
             state => 'state',
             'ttl-eq' => 'ttl',
             'ttl-gt' => 'ttl',
             'ttl-lt' => 'ttl',
             timestart => 'time',
             timestop => 'time',
             days => 'time',
             datestart => 'time',
             datestop => 'time',
           );

# these hashes provide the Netfilter module definitions
use vars qw(%proto_defs %match_defs %target_defs);

#
# This subsubsystem allows you to support (most) new netfilter modules
# in ferm.  Add a call to one of the "add_XY_def()" functions below.
#
# Ok, now about the cryptic syntax: the function "add_XY_def()"
# registers a new module.  There are three kinds of modules: protocol
# module (e.g. TCP, ICMP), match modules (e.g. state, physdev) and
# target modules (e.g. DNAT, MARK).
#
# The first parameter is always the module name which is passed to
# iptables with "-p", "-m" or "-j" (depending on which kind of module
# this is).
#
# After that, you add an encoded string for each option the module
# supports.  This is where it becomes tricky.
#
# foo           defaults to an option with one argument (which may be a ferm
#               array)
#
# foo*0         option without any arguments
#
# foo=s         one argument which must not be a ferm array ('s' stands for
#               'scalar')
#
# u32=m         an array which renders into multiple iptables options in one
#               rule
#
# ctstate=c     one argument, if it's an array, pass it to iptables as a
#               single comma separated value; example:
#                 ctstate (ESTABLISHED RELATED)  translates to:
#                 --ctstate ESTABLISHED,RELATED
#
# foo=sac       three arguments: scalar, array, comma separated; you may
#               concatenate more than one letter code after the '='
#
# foo&bar       one argument; call the perl function '&bar()' which parses
#               the argument
#
# !foo          negation is allowed and the '!' is written before the keyword
#
# foo!          same as above, but '!' is after the keyword and before the
#               parameters
#
# to:=to-destination    makes "to" an alias for "to-destination"; you have
#                       to add a declaration for option "to-destination"
#

# add a module definition
sub add_def {
    my $defs = shift;
    my $name = shift;
    die if exists $defs->{$name};
    my $def = $defs->{$name} = {};
    foreach (@_) {
        my $keyword = $_;
        my $k = {};

        my $params = 1;
        $params = $1 if $keyword =~ s,\*(\d+)$,,;
        $params = $1 if $keyword =~ s,=([acs]+|m)$,,;
        if ($keyword =~ s,&(\S+)$,,) {
            $params = eval "\\&$1";
            die $@ if $@;
        }
        $k->{params} = $params if $params;

        $k->{negation} = $k->{pre_negation} = 1 if $keyword =~ s,^!,,;
        $k->{negation} = 1 if $keyword =~ s,!$,,;

        $k->{alias} = $1 if $keyword =~ s,:=(\S+)$,,;

        $def->{keywords}{$keyword} = $k;
    }

    return $def;
}

# add a protocol module definition
sub add_proto_def(@) {
    add_def(\%proto_defs, @_);
}

# add a match module definition
sub add_match_def(@) {
    add_def(\%match_defs, @_);
}

# add a target module definition
sub add_target_def(@) {
    add_def(\%target_defs, @_);
}

add_proto_def 'dccp', qw(dccp-types!=c dccp-option!);
add_proto_def 'mh', qw(mh-type!);
add_proto_def 'icmp', qw(icmp-type!);
add_proto_def 'icmpv6', qw(icmpv6-type! icmp-type:=icmpv6-type);
add_proto_def 'sctp', qw(chunk-types!=sc);
add_proto_def 'tcp', qw(tcp-flags!=cc !syn*0 tcp-option! mss);
add_proto_def 'udp', qw();

add_match_def 'account', qw(aaddr=s aname=s ashort*0);
add_match_def 'addrtype', qw(src-type dst-type);
add_match_def 'ah', qw(ahspi! ahlen! ahres*0);
add_match_def 'comment', qw(comment=s);
add_match_def 'condition', qw(condition!);
add_match_def 'connbytes', qw(!connbytes connbytes-dir connbytes-mode);
add_match_def 'connlimit', qw(!connlimit-above connlimit-mask);
add_match_def 'connmark', qw(mark);
add_match_def 'conntrack', qw(ctstate=c ctproto ctorigsrc! ctorigdst!),
  qw(ctreplsrc! ctrepldst! ctstatus ctexpire=s);
add_match_def 'dscp', qw(dscp dscp-class);
add_match_def 'dst', qw(dst-len!=s dst-opts=c);
add_match_def 'ecn', qw(ecn-tcp-cwr*0 ecn-tcp-ece*0 ecn-ip-ect);
add_match_def 'esp', qw(espspi!);
add_match_def 'eui64';
add_match_def 'frag', qw(fragid! fraglen! fragres*0 fragmore*0 fragfirst*0 fraglast*0);
add_match_def 'fuzzy', qw(lower-limit=s upper-limit=s);
add_match_def 'hbh', qw(hbh-len! hbh-opts=c);
add_match_def 'helper', qw(helper);
add_match_def 'hl', qw(hl-eq! hl-lt=s hl-gt=s);
add_match_def 'length', qw(length!);
add_match_def 'hashlimit', qw(hashlimit=s hashlimit-burst=s hashlimit-mode=s hashlimit-name=s),
  qw(hashlimit-htable-size=s hashlimit-htable-max=s),
  qw(hashlimit-htable-expire=s hashlimit-htable-gcinterval=s);
add_match_def 'iprange', qw(!src-range !dst-range);
add_match_def 'iplimit', qw(!iplimit-above=s iplimit-mask=s);
add_match_def 'ipv6header', qw(header!=c soft*0);
add_match_def 'limit', qw(limit=s limit-burst=s);
add_match_def 'mac', qw(mac-source!);
add_match_def 'mark', qw(mark);
add_match_def 'multiport', qw(source-ports!&multiport_params),
  qw(destination-ports!&multiport_params ports!&multiport_params);
add_match_def 'nth', qw(every counter start packet);
add_match_def 'owner', qw(uid-owner gid-owner pid-owner sid-owner cmd-owner);
add_match_def 'physdev', qw(physdev-in! physdev-out!),
  qw(!physdev-is-in*0 !physdev-is-out*0 !physdev-is-bridged*0);
add_match_def 'pkttype', qw(pkt-type),
add_match_def 'policy',
  qw(dir pol strict*0 reqid spi proto mode tunnel-src tunnel-dst next*0);
add_match_def 'psd', qw(psd-weight-threshold psd-delay-threshold),
  qw(psd-lo-ports-weight psd-hi-ports-weight);
add_match_def 'quota', qw(quota=s);
add_match_def 'random', qw(average);
add_match_def 'realm', qw(realm!);
add_match_def 'recent', qw(name=s !set*0 !rcheck*0 !update*0 !seconds !hitcount rttl*0);
add_match_def 'rt', qw(rt-type! rt-segsleft! rt-len! rt-0-res*0 rt-0-addrs=c rt-0-not-strict*0);
add_match_def 'set', qw(set=sc);
add_match_def 'state', qw(state=c);
add_match_def 'statistic', qw(mode=s probability=s every=s packet=s);
add_match_def 'tcpmss', qw(!mss);
add_match_def 'time', qw(timestart=s timestop=s days=c datestart=s datestop=s);
add_match_def 'tos', qw(!tos&compat_tos_params);
add_match_def 'ttl', qw(ttl-eq ttl-lt=s ttl-gt=s);
add_match_def 'u32', qw(u32=m);

add_target_def 'BALANCE', qw(to-destination to:=to-destination);
add_target_def 'CLASSIFY', qw(set-class);
add_target_def 'CONNMARK', qw(set-mark save-mark*0 restore-mark*0 mask);
add_target_def 'CONNSECMARK', qw(save*0 restore*0);
add_target_def 'DNAT', qw(to-destination to:=to-destination);
add_target_def 'DSCP', qw(set-dscp set-dscp-class);
add_target_def 'ECN', qw(ecn-tcp-remove*0);
add_target_def 'HL', qw(hl-set hl-dec hl-inc);
add_target_def 'LOG', qw(log-level log-prefix),
  qw(log-tcp-sequence*0 log-tcp-options*0 log-ip-options*0 log-uid*0);
add_target_def 'MARK', qw(set-mark);
add_target_def 'MASQUERADE', qw(to-ports);
add_target_def 'MIRROR';
add_target_def 'NETMAP', qw(to);
add_target_def 'NFLOG', qw(nflog-group nflog-prefix nflog-range nflog-threshold);
add_target_def 'NFQUEUE', qw(queue-num);
add_target_def 'NOTRACK';
add_target_def 'REDIRECT', qw(to-ports);
add_target_def 'REJECT', qw(reject-with);
add_target_def 'ROUTE', qw(oif iif gw continue*0 tee*0);
add_target_def 'SAME', qw(to nodst*0);
add_target_def 'SECMARK', qw(selctx);
add_target_def 'SET', qw(add-set=sc del-set=sc);
add_target_def 'SNAT', qw(to-source=m to:=to-source);
add_target_def 'TARPIT';
add_target_def 'TCPMSS', qw(set-mss clamp-mss-to-pmtu*0);
add_target_def 'TOS', qw(set-tos&compat_tos_params);
add_target_def 'TRACE';
add_target_def 'TTL', qw(ttl-set ttl-dec ttl-inc);
add_target_def 'ULOG', qw(ulog-nlgroup ulog-prefix ulog-cprange ulog-qthreshold);

# parameter parser for ipt_multiport
sub multiport_params {
    my $fw = shift;

    # multiport only allows 15 ports at a time. For this
    # reason, we do a little magic here: split the ports
    # into portions of 15, and handle these portions as
    # array elements

    my $proto = find_option($fw, 'proto');
    error('To use multiport, you have to specify "proto tcp" or "proto udp" first')
      unless defined $proto and grep { /^(?:tcp|udp|udplite)$/ } to_array($proto);

    my $value = getvalues(undef, undef,
                          allow_negation => 1,
                          allow_array_negation => 1);
    if (ref $value and ref $value eq 'ARRAY') {
        my @value = @$value;
        my @params;

        while (@value) {
            push @params, join(',', splice(@value, 0, 15));
        }

        return @params == 1
          ? $params[0]
            : \@params;
    } else {
        return join_value(',', $value);
    }
}

# parameter parser for ipt_tos
sub compat_tos_params {
    my $value = getvalues(undef, undef, allow_negation => 1);

    return $value if ref $value and ref $value eq 'negated';

    # ferm 1.1 allowed some abbreviations.  It is this function's only
    # job to translate these deprecated keywords to the "real" ones.
    my @value = map {
        my $value = $_;
        $value =~ s/^min-?cost$/0x02/;
        $value =~ s/^(?:reliability|reliable)$/0x04/;
        $value =~ s/^max-?throughput$/0x08/;
        $value =~ s/^(?:lowdelay|interactive|min-delay)$/0x10/;
        $value =~ s/^clear$/0x00/;
        $value
    } to_array($value);

    return @value == 1 ? $value[0] : \@value;
}

# initialize stack: command line definitions
unshift @stack, {};

# Get command line stuff
if ($has_getopt) {
    my ($opt_noexec, $opt_flush, $opt_lines, $opt_interactive,
        $opt_verbose, $opt_debug,
        $opt_location, $opt_clearall, $opt_flushall,
        $opt_createchains, $opt_flushchains, $opt_help, $opt_automod,
        $opt_version, $opt_use, $opt_test, $opt_fast, $opt_shell,
        $opt_domain);

    Getopt::Long::Configure('bundling', 'auto_help', 'no_ignore_case',
                            'no_auto_abbrev');

    sub opt_def {
        my ($opt, $value) = @_;
        die 'Invalid --def specification'
          unless $value =~ /^\$?(\w+)=(.*)$/s;
        my ($name, $unparsed_value) = ($1, $2);
        my @tokens = tokenize_string($unparsed_value);
        my $value = getvalues(\&next_array_token, \@tokens);
        die 'Extra tokens after --def'
          if @tokens;
        $stack[0]{vars}{$name} = $value;
    }

    local $SIG{__WARN__} = sub { die $_[0]; };
    GetOptions('noexec|n' => \$opt_noexec,
               'flush|F' => \$opt_flush,
               'lines|l' => \$opt_lines,
               'interactive|i' => \$opt_interactive,
               'verbose|v' => \$opt_verbose,
               'debug|d' => \$opt_debug,
               'location=s' => \$opt_location,
               clearall => \$opt_clearall,
               flushall => \$opt_flushall,
               createchains => \$opt_createchains,
               flushchains => \$opt_flushchains,
               'help|h' => \$opt_help,
               automod => \$opt_automod,
               'version|V' => \$opt_version,
               'use=s' => \$opt_use,
               test => \$opt_test,
               remote => \$opt_test,
               fast => \$opt_fast,
               shell => \$opt_shell,
               'domain=s' => \$opt_domain,
               'def=s' => \&opt_def,
              );

    if (defined $opt_help) {
        require Pod::Usage;
        Pod::Usage::pod2usage(-exitstatus => 0);
    }

    if (defined $opt_version) {
        printversion();
        exit 0;
    };

    $option{'noexec'} = (defined $opt_noexec);
    $option{flush} = defined $opt_flush;
    $option{'lines'} = (defined $opt_lines);
    $option{interactive} = (defined $opt_interactive);
    $option{'automod'} = (defined $opt_automod);
    $option{test} = (defined $opt_test);

    if ($option{test}) {
        $option{noexec} = 1;
        $option{lines} = 1;
    }

    delete $option{interactive} if $option{noexec};

    mydie('ferm interactive mode not possible: /dev/stdin is not a tty')
      if $option{interactive} and not -t STDIN;
    mydie('ferm interactive mode not possible: /dev/stderr is not a tty')
      if $option{interactive} and not -t STDERR;

    $option{fast} = 1 if defined $opt_fast;

    if (defined $opt_shell) {
        $option{$_} = 1 foreach qw(shell fast lines);
    }

    $option{domain} = $opt_domain if defined $opt_domain;

    print STDERR "Warning: --automod is deprecated\n"
      if defined $opt_automod;

    print STDERR "Warning: ignoring the obsolete --use/-s option\n"
      if defined $opt_use;

    print STDERR "Warning: ignoring the obsolete --debug option\n"
      if defined $opt_debug;
    print STDERR "Warning: ignoring the obsolete --verbose option\n"
      if defined $opt_verbose;
    print STDERR "Warning: ignoring the obsolete --clearall option\n"
      if defined $opt_clearall;
    print STDERR "Warning: ignoring the obsolete --flushall option\n"
      if defined $opt_flushall;
    print STDERR "Warning: ignoring the obsolete --flushchains option\n"
      if defined $opt_flushchains;
    print STDERR "Warning: ignoring the obsolete --createchains option\n"
      if defined $opt_createchains;
    print STDERR "Warning: ignoring the obsolete --location option\n"
      if defined $opt_location;
} else {
    # tiny getopt emulation for microperl
    my $filename;
    foreach (@ARGV) {
        if ($_ eq '--noexec' or $_ eq '-n') {
            $option{noexec} = 1;
        } elsif ($_ eq '--lines' or $_ eq '-l') {
            $option{lines} = 1;
        } elsif ($_ eq '--fast') {
            $option{fast} = 1;
        } elsif ($_ eq '--test') {
            $option{test} = 1;
            $option{noexec} = 1;
            $option{lines} = 1;
        } elsif ($_ eq '--shell') {
            $option{$_} = 1 foreach qw(shell fast lines);
        } elsif (/^-/) {
            printf STDERR "Usage: ferm [--noexec] [--lines] [--fast] [--shell] FILENAME\n";
            exit 1;
        } else {
            $filename = $_;
        }
    }
    undef @ARGV;
    push @ARGV, $filename;
}

unless (@ARGV == 1) {
    require Pod::Usage;
    Pod::Usage::pod2usage(-exitstatus => 1);
}

if ($has_strict) {
    open LINES, ">&STDOUT" if $option{lines};
    open STDOUT, ">&STDERR" if $option{shell};
} else {
    # microperl can't redirect file handles
    *LINES = *STDOUT;

    if ($option{fast} and not $option{noexec}) {
        print STDERR "Sorry, ferm on microperl does not allow --fast without --noexec\n";
        exit 1
    }
}

unshift @stack, {};
open_script($ARGV[0]);
read_header();

# parse all input recursively
enter(0);
die unless @stack == 2;

# check consistency
check();

# execute all generated rules
my $status;

foreach my $cmd (@pre_hooks) {
    print LINES "$cmd\n" if $option{lines};
    system($cmd) unless $option{noexec};
}

while (my ($domain, $rules) = each %rules) {
    my $s = $option{fast}
      ? execute_fast($domain, rules_to_save($domain, $rules))
        : execute_slow($domain, $rules);
    $status = $s if defined $s;
}

foreach my $cmd (@post_hooks) {
    print "$cmd\n" if $option{lines};
    system($cmd) unless $option{noexec};
}

if (defined $status) {
    rollback();
    exit $status;
}

# ask user, and rollback if there is no confirmation

confirm_rules() or rollback() if $option{interactive};

exit 0;

# end of program execution!


# funcs

sub printversion {
    print "ferm $VERSION\n";
    print "Copyright (C) 2001-2007 Auke Kok, Max Kellermann\n";
    print "This program is free software released under GPLv2.\n";
    print "See the included COPYING file for license details.\n";
}


sub mydie {
    print STDERR @_;
    print STDERR "\n";
    exit 1;
}


sub error {
    # returns a nice formatted error message, showing the
    # location of the error.
    my $tabs = 0;
    my @lines;
    my $l = 0;
    my @words = @{$script->{past_tokens}};

    for my $w ( 0 .. $#words ) {
        if ($words[$w] eq "\x29")
            { $l++ ; $lines[$l] = "    " x ($tabs-- -1) ;};
        if ($words[$w] eq "\x28")
            { $l++ ; $lines[$l] = "    " x $tabs++ ;};
        if ($words[$w] eq "\x7d")
            { $l++ ; $lines[$l] = "    " x ($tabs-- -1) ;};
        if ($words[$w] eq "\x7b")
            { $l++ ; $lines[$l] = "    " x $tabs++ ;};
        if ( $l > $#lines ) { $lines[$l] = "" };
        $lines[$l] .= $words[$w] . " ";
        if ($words[$w] eq "\x28")
            { $l++ ; $lines[$l] = "    " x $tabs ;};
        if (($words[$w] eq "\x29") && ($words[$w+1] ne "\x7b"))
            { $l++ ; $lines[$l] = "    " x $tabs ;};
        if ($words[$w] eq "\x7b")
            { $l++ ; $lines[$l] = "    " x $tabs ;};
        if (($words[$w] eq "\x7d") && ($words[$w+1] ne "\x7d"))
            { $l++ ; $lines[$l] = "    " x $tabs ;};
        if (($words[$w] eq "\x3b") && ($words[$w+1] ne "\x7d"))
            { $l++ ; $lines[$l] = "    " x $tabs ;}
        if ($words[$w-1] eq "option")
            { $l++ ; $lines[$l] = "    " x $tabs ;}
    }
    my $start = $#lines - 4;
    if ($start < 0) { $start = 0 } ;
    print STDERR "Error in $script->{filename} line $script->{line}:\n";
    for $l ( $start .. $#lines)
        { print STDERR $lines[$l]; if ($l != $#lines ) {print STDERR "\n"} ; };
    print STDERR "<--\n";
    mydie(@_);
}

# print a warning message about code from an input file
sub warning {
    print STDERR "Warning in $script->{filename} line $script->{line}: "
      . (shift) . "\n";
}

sub find_tool($) {
    my $name = shift;
    return $name if $option{test};
    for my $path ('/sbin', split ':', $ENV{PATH}) {
        my $ret = "$path/$name";
        return $ret if -x $ret;
    }
    die "$name not found in PATH\n";
}

sub initialize_domain {
    my $domain = shift;

    return if exists $domains{$domain}{initialized};

    die "Invalid domain '$domain'\n" unless $domain =~ /^ip6?$/;

    my @tools = qw(tables tables-save tables-restore);

    # determine the location of this domain's tools
    foreach my $tool (@tools) {
        $domains{$domain}{tools}{$tool} = find_tool("${domain}${tool}");
    }

    # make tables-save tell us about the state of this domain
    # (which tables and chains do exist?), also remember the old
    # save data which may be used later by the rollback function
    local *SAVE;
    if (!$option{test} &&
        open(SAVE, "$domains{$domain}{tools}{'tables-save'}|")) {
        my $save = '';

        my $table_info;
        while (<SAVE>) {
            $save .= $_;

            if (/^\*(\w+)/) {
                my $table = $1;
                $table_info = $domains{$domain}{tables}{$table} ||= {};
            } elsif (defined $table_info and /^:(\w+)\s+(\S+)/
                     and $2 ne '-') {
                $table_info->{chains}{$1}{builtin} = 1;
                $table_info->{has_builtin} = 1;
            }
        }

        # for rollback
        $domains{$domain}{previous} = $save;
    }

    $domains{$domain}{initialized} = 1;
}

# split the an input string into words and delete comments
sub tokenize_string($) {
    my $string = shift;

    my @ret;

    foreach my $word ($string =~ m/(".*?"|'.*?'|`.*?`|[!,=&\$\%\(\){};]|[-+\w\/\.:]+|@\w+|#)/g) {
        last if $word eq '#';
        push @ret, $word;
    }

    return @ret;
}

# shift an array; helper function to be passed to &getvar / &getvalues
sub next_array_token {
    my $array = shift;
    shift @$array;
}

# read the header of a ferm script, handle (deprecated) syntax
sub read_header() {
    die unless defined $script;
    die if defined $script->{parent};

    my $tokens = $script->{tokens};
    die unless ref $tokens eq 'ARRAY';
    die if @$tokens;

    while (1) {
        my $handle = $script->{handle};
        my $line = <$handle>;
        return unless defined $line;

        $script->{line} ++;

        my @line = tokenize_string($line);
        next unless @line;

        map { s/^(["'])(.*)\1$/$2/s } @line;

        # look at the first word, then decide what to do. some special
        # keywords are handled here, everything else gets added to @tokens
        if ($line[0] eq 'option') {
            # option: edit the %option hash
            shift @line;
            my $name = shift @line;
            my $value = shift @line;

            unless (defined $value) {
                $value = 1;
            } elsif ($value eq 'off') {
                $value = undef;
            }

            if ($value and $name =~ /^(?:ipchains|iptables|ipfwadm)$/) {
                print STDERR "The options ipchains, iptables and ipfwadm are obsolete, ignoring them\n";
            } else {
                print STDERR "The 'option' keyword is deprecated\n";
                $option{$name} = $value;
            }
        } elsif ($line[0] eq 'set') {
            # set: set a variable
            shift @line;
            my $name = getvar(\&next_array_token, \@line);
            my $value = getvalues(\&next_array_token, \@line);

            warning('"set" is deprecated, please use "def $NAME = VALUE;"');

            if (@line and $line[0] eq ',') {
                warning('Arrays without parentheses are deprecated');

                $value = [ $value ]
                  unless ref $value;

                do {
                    shift @line;
                    my $v = getvalues(\&next_array_token, \@line);
                    push @$value, ref $v ? @$v : $v;
                } while (@line and $line[0] eq ',');
            }

            error('spare tokens after "set"')
              if @line;

            $oldvars{$name} = $value;
        } else {
            # the next parser stage eats this
            push @$tokens, @line;
            last;
        }
    }

    return 1;
}

# read some more tokens from the input file into a buffer
sub prepare_tokens() {
    return
      unless defined $script;

    my $tokens = $script->{tokens};
    die unless ref $tokens eq 'ARRAY';

    while (@$tokens == 0) {
        my $handle = $script->{handle};
        my $line = <$handle>;
        return unless defined $line;

        $script->{line} ++;

        my @line = tokenize_string($line);

        # the next parser stage eats this
        push @$tokens, @line;
    }

    return 1;
}

# open a ferm sub script
sub open_script($) {
    my $filename = shift;

    for (my $s = $script; defined $s; $s = $s->{parent}) {
        mydie("Circular reference in $script->{filename} line $script->{line}: $filename")
          if $s->{filename} eq $filename;
    }

    local *FILE;
    open FILE, "<$filename"
      or mydie("Failed to open $filename: $!");
    my $handle = *FILE;

    $script = { filename => $filename,
                handle => $handle,
                line => 0,
                past_tokens => [],
                tokens => [],
                parent => $script,
              };

    return $script;
}

# collect script filenames which are being included
sub collect_filenames(@) {
    my @ret;

    # determine the current script's parent directory for relative
    # file names
    die unless defined $script;
    my $parent_dir = $script->{filename} =~ m,^(.*/),
      ? $1 : './';

    foreach my $pathname (@_) {
        # non-absolute file names are relative to the parent script's
        # file name
        $pathname = $parent_dir . $pathname
          unless $pathname =~ m,^/,;

        if ($pathname =~ m,/$,) {
            # include all regular files in a directory

            error("'$pathname' is not a directory")
              unless -d $pathname;

            local *DIR;
            opendir DIR, $pathname
              or error("Failed to open directory '$pathname': $!");
            my @names = readdir DIR;
            closedir DIR;

            # sort those names for a well-defined order
            foreach my $name (sort { $a cmp $b } @names) {
                # don't include hidden and backup files
                next if /^\.|~$/;

                my $filename = $pathname . $name;
                push @ret, $filename
                  if -f $filename;
            }
        } elsif ($pathname =~ m,\|$,) {
            # run a program and use its output
            push @ret, $pathname;
        } elsif ($pathname =~ m,^\|,) {
            error('This kind of pipe is not allowed');
        } else {
            # include a regular file

            error("'$pathname' is a directory; maybe use trailing '/' to include a directory?")
              if -d $pathname;
            error("'$pathname' is not a file")
              unless -f $pathname;

            push @ret, $pathname;
        }
    }

    return @ret;
}

# peek a token from the queue, but don't remove it
sub peek_token() {
    # get a token
    prepare_tokens();

    return
      unless defined $script;

    my $tokens = $script->{tokens};
    die unless ref $tokens eq 'ARRAY';

    return
      unless @$tokens;

    return $tokens->[0];
}

# get a token from the queue
sub next_token() {
    prepare_tokens();

    return
      unless defined $script;

    my $tokens = $script->{tokens};
    die unless ref $tokens eq 'ARRAY';

    return
      unless @$tokens;

    my $token = shift @$tokens;

    # update $script->{past_tokens}
    my $past_tokens = $script->{past_tokens};
    die unless ref $past_tokens eq 'ARRAY';

    if (@$past_tokens and
        ($past_tokens->[@$past_tokens - 1] eq '}' or
         $past_tokens->[@$past_tokens - 1] eq ';')) {
        # now this is tricky: $script->{past_tokens} is used in error
        # messages. in the following lines, we filter out everything
        # which has become irrelevant for error messages,
        # i.e. previous (completed) commands

        my $t = pop @$past_tokens;

        # track the current level - a '}' means one level up (we are
        # going backwards)
        my $level = $t eq '}' ? 1 : 0;

        while (@$past_tokens and $level >= 0) {
            $t = pop @$past_tokens;

            if ($level == 0 and ($t eq '}' or $t eq ';')) {
                # don't delete another command
                push @$past_tokens, $t;
                last;
            } elsif ($t eq '}') {
                # one level up
                $level++;
            } elsif ($t eq '{') {
                # one level down. stop here if we're already at level
                # zero
                if ($level == 0) {
                    push @$past_tokens, $t;
                    last;
                }

                $level--;
            }
        }
    }

    push @$past_tokens, $token;

    # return
    return $token;
}

# require that another token exists, and that it's not a "special"
# token, e.g. ";" and "{"
sub require_next_token {
    my $code = shift || \&next_token;

    my $token = &$code(@_);

    error('unexpected end of file')
      unless defined $token;

    error("'$token' not allowed here")
      if $token =~ /^[;{}]$/;

    return $token;
}

# determine the value of an old style variable, die if the variable is
# unknown
sub old_variable_value($) {
    my $name = shift;

    error("no such variable: \%$name")
      unless exists $oldvars{$name};

    return $oldvars{$name};
}

# determine the value of a variable, die if the value is an array
sub string_old_variable_value($) {
    my $name = shift;
    my $value = old_variable_value($name);

    error("variable '$name' must be a string, is an array")
      if ref $value;

    return $value;
}

# resolve all old style variable references in the string - may be an
# array!
sub resolve_old_variable_refs($) {
    my $token = shift;

    if ($token =~ /^\%(\w+)$/) {
        # if the token only of the reference, return the pure value
        return old_variable_value($1);
    } else {
        # a reference in the middle of the string. replace, but only
        # allow string variables, no arrays here
        $token =~ s/\%(\w+)/string_old_variable_value($1)/eg;

        return $token;
    }
}

# return the value of a variable
sub variable_value($) {
    my $name = shift;

    foreach (@stack) {
        return $_->{vars}{$name}
          if exists $_->{vars}{$name};
    }

    return $stack[0]{auto}{$name}
      if exists $stack[0]{auto}{$name};

    return;
}

# determine the value of a variable, die if the value is an array
sub string_variable_value($) {
    my $name = shift;
    my $value = variable_value($name);

    error("variable '$name' must be a string, is an array")
      if ref $value;

    return $value;
}

# similar to the built-in "join" function, but also handle negated
# values in a special way
sub join_value($$) {
    my ($expr, $value) = @_;

    unless (ref $value) {
        return $value;
    } elsif (ref $value eq 'ARRAY') {
        return join($expr, @$value);
    } elsif (ref $value eq 'negated') {
        # bless'negated' is a special marker for negated values
        $value = join_value($expr, $value->[0]);
        return bless [ $value ], 'negated';
    } else {
        die;
    }
}

# returns the next parameter, which may either be a scalar or an array
sub getvalues {
    my ($code, $param) = (shift, shift);
    my %options = @_;

    my $token = require_next_token($code, $param);

    if ($token eq '(') {
        # read an array until ")"
        my @wordlist;

        for (;;) {
            $token = getvalues($code, $param,
                               parenthesis_allowed => 1,
                               comma_allowed => 1);

            unless (ref $token) {
                last if $token eq ')';

                if ($token eq ',') {
                    warning('Comma within arrays is deprecated, please use only a space');
                    next;
                }

                push @wordlist, $token;
            } elsif (ref $token eq 'ARRAY') {
                push @wordlist, @$token;
            } else {
                error('unknown toke type');
            }
        }

        error('empty array not allowed here')
          unless @wordlist or not $options{non_empty};

        return @wordlist == 1
          ? $wordlist[0]
            : \@wordlist;
    } elsif ($token =~ /^\`(.*)\`$/s) {
        # execute a shell command, insert output
        my $command = $1;
        my $output = `$command`;
        unless ($? == 0) {
            if ($? == -1) {
                error("failed to execute: $!");
            } elsif ($? & 0x7f) {
                error("child died with signal " . ($? & 0x7f));
            } elsif ($? >> 8) {
                error("child exited with status " . ($? >> 8));
            }
        }

        # remove comments
        $output =~ s/#.*//mg;

        # tokenize
        my @tokens = grep { length } split /\s+/s, $output;

        my @values;
        while (@tokens) {
            my $value = getvalues(\&next_array_token, \@tokens);
            push @values, to_array($value);
        }

        # and recurse
        return @values == 1
          ? $values[0]
            : \@values;
    } elsif ($token =~ /^\'(.*)\'$/s) {
        # single quotes: a string
        return resolve_old_variable_refs($1);
    } elsif ($token =~ /^\"(.*)\"$/s) {
        # double quotes: a string with escapes
        $token = resolve_old_variable_refs($1);
        $token =~ s,\$(\w+),string_variable_value($1),eg;
        return $token;
    } elsif ($token eq '!') {
        error('negation is not allowed here')
          unless $options{allow_negation};

        $token = getvalues($code, $param);

        error('it is not possible to negate an array')
          if ref $token and not $options{allow_array_negation};

        return bless [ $token ], 'negated';
    } elsif ($token =~ /^.+,.+$/) {
        warning('Arrays within a string are deprecated, please use parentheses');

        my @array = map {
            my $value = resolve_old_variable_refs($_);
            ref $value ? @$value : $value;
        } split(/,/, $token);

        return \@array;
    } elsif ($token eq ',') {
        return $token
          if $options{comma_allowed};

        error('comma is not allowed here');
    } elsif ($token eq '=') {
        error('equals operator ("=") is not allowed here');
    } elsif ($token eq '$') {
        my $name = require_next_token($code, $param);
        error('variable name expected - if you want to concatenate strings, try using double quotes')
          unless $name =~ /^\w+$/;

        my $value = variable_value($name);

        error("no such variable: \$$name")
          unless defined $value;

        return $value;
    } elsif ($token eq '%') {
        my $name = require_next_token($code, $param);
        error('variable name expected')
          unless $name =~ /^\w+$/;

        return old_variable_value($name);
    } elsif ($token eq '&') {
        error("function calls are not allowed as keyword parameter");
    } elsif ($token eq ')' and not $options{parenthesis_allowed}) {
        error('Syntax error');
    } elsif ($token =~ /^@/) {
        if ($token eq '@resolve') {
            my @params = get_function_params();
            error('Usage: @resolve((hostname ...))')
              unless @params == 1;
            eval { require Net::DNS; };
            error('For the @resolve() function, you need the Perl library Net::DNS')
              if $@;
            my $type = 'A';
            my $resolver = new Net::DNS::Resolver;
            my @result;
            foreach my $hostname (to_array($params[0])) {
                my $query = $resolver->search($hostname, $type);
                error("DNS query for '$hostname' failed: " . $resolver->errorstring)
                  unless $query;
                foreach my $rr ($query->answer) {
                    next unless $rr->type eq $type;
                    push @result, $rr->address;
                }
            }
            return \@result;
        } else {
            error("unknown ferm built-in function");
        }
    } else {
        return resolve_old_variable_refs($token);
    }
}

# returns the next parameter, but only allow a scalar
sub getvar {
    my $token = getvalues(@_);

    error('array not allowed here')
      if ref $token and ref $token eq 'ARRAY';

    return $token;
}

sub get_function_params(%) {
    my $token = next_token();
    error('function name must be followed by "()"')
      unless defined $token and $token eq '(';

    $token = peek_token();
    if ($token eq ')') {
        require_next_token;
        return;
    }

    my @params;

    while (1) {
        if (@params > 0) {
            $token = require_next_token();
            last
              if $token eq ')';

            error('"," expected')
              unless $token eq ',';
        }

        push @params, getvalues(undef, undef, @_);
    }

    return @params;
}

# collect all tokens in a flat array reference until the end of the
# command is reached
sub collect_tokens() {
    my @level;
    my @tokens;

    while (1) {
        my $keyword = next_token();
        error('unexpected end of file within function/variable declaration')
          unless defined $keyword;

        if ($keyword =~ /^[\{\(]$/) {
            push @level, $keyword;
        } elsif ($keyword =~ /^[\}\)]$/) {
            my $expected = $keyword;
            $expected =~ tr/\}\)/\{\(/;
            my $opener = pop @level;
            error("unmatched '$keyword'")
              unless defined $opener and $opener eq $expected;
        } elsif ($keyword eq ';' and @level == 0) {
            last;
        }

        push @tokens, $keyword;

        last
          if $keyword eq '}' and @level == 0;
    }

    return \@tokens;
}


# returns the specified value as an array. dereference arrayrefs
sub to_array($) {
    my $value = shift;
    die unless wantarray;
    die if @_;
    unless (ref $value) {
        return $value;
    } elsif (ref $value eq 'ARRAY') {
        return @$value;
    } else {
        die;
    }
}

# evaluate the specified value as bool
sub eval_bool($) {
    my $value = shift;
    die if wantarray;
    die if @_;
    unless (ref $value) {
        return $value;
    } elsif (ref $value eq 'ARRAY') {
        return @$value > 0;
    } else {
        die;
    }
}

sub is_netfilter_core_target($) {
    my $target = shift;
    die unless defined $target and length $target;

    return $target =~ /^(?:ACCEPT|DROP|RETURN|QUEUE)$/;
}

sub is_netfilter_module_target($) {
    my $target = shift;
    die unless defined $target and length $target;

    return exists $target_defs{$target};
}

sub is_netfilter_builtin_chain($$) {
    my ($table, $chain) = @_;

    return grep { $_ eq $chain }
      qw(PREROUTING INPUT FORWARD OUTPUT POSTROUTING);
}

# escape the string in a way safe for the shell
sub shell_escape($) {
    my $token = shift;

    if ($option{fast}) {
        # iptables-save/iptables-restore are quite buggy concerning
        # escaping and special characters... we're trying our best
        # here

        $token =~ s,",',g;
        $token = '"' . $token . '"'
          if $token =~ /[\s\'\\;&]/s;
    } else {
        return $token
          if $token =~ /^\`.*\`$/;
        $token =~ s/'/\\'/g;
        $token = '\'' . $token . '\''
          if $token =~ /[\s\"\\;<>&|]/s;
    }

    return $token;
}

# append parameters to a shell command line, with the correct escape
# sequences
sub shell_append($@) {
    my $ref = shift;

    foreach (@_) {
        $$ref .= ' ' . shell_escape($_);
    }
}

# append an option to the shell command line, using information from
# the module definition (see %match_defs etc.)
sub shell_append_option($$$$) {
    my ($ref, $def, $keyword, $value) = @_;

    my @negated;
    if (ref $value and ref $value eq 'negated') {
        $value = $value->[0];

        if (exists $def->{pre_negation}) {
            shell_append($ref, '!');
        } else {
            push @negated, '!';
        }
    }

    unless (defined $value) {
        shell_append($ref, "--$keyword");
    } elsif (ref $value and ref $value eq 'params') {
        shell_append($ref, "--$keyword", @negated, @$value);
    } elsif (ref $value and ref $value eq 'multi') {
        foreach (@$value) {
            shell_append($ref, "--$keyword", $_);
        }
    } else {
        shell_append($ref, "--$keyword", @negated, $value);
    }
}

# dereference a bless'negated'
sub extract_negation($) {
    local $_ = shift;
    ref && ref eq 'negated'
      ? ( '!', $_->[0] )
        : $_;
}

# reset a netfilter domain: set all policies to ACCEPT, clear all
# rules, delete custom chains
sub reset_domain($) {
    my $domain = shift;
    my $domain_info = $domains{$domain};

    my $path = $domain_info->{tools}{tables};

    my @rules;
    while (my ($table, $table_info) = each %{$domain_info->{tables}}) {
        while (my ($chain, $chain_info) = each %{$table_info->{chains}}) {
            next unless $chain_info->{builtin} or
              (not $table_info->{has_builtin} and
               is_netfilter_builtin_chain($table, $chain));
            push @rules, "$path -t $table -P $chain ACCEPT\n";
        }

        push @rules,
          "$path -t $table -F\n", "$path -t $table -X\n";
    }

    return @rules;
}

# convert an internal rule structure into an iptables call
sub tables($) {
    my $rule = shift;
    my %rule = %$rule;

    my $domain = $rule{domain};
    my $domain_info = $domains{$domain};

    my $table = $rule{table};
    my $table_info = $domain_info->{tables}{$table} ||= {};

    my $rules = $rules{$domain} ||= [];

    my $chain = $rule{chain};
    my $chain_info = $table_info->{chains}{$chain} ||= {};

    return if $option{flush};

    my $action = $rule{action};

    my $rr = shell_escape($domain_info->{tools}{tables});
    shell_append(\$rr, '-t', $table);

    # should we set a policy?
    if (exists $chain_info->{set_policy}) {
        my $policy = $chain_info->{policy};

        push @$rules, "$rr -P $chain $policy\n";

        delete $chain_info->{set_policy};
    }

    # mark this chain as "non-empty" because we will add stuff to
    # it now; this flag is later used to check if a custom chain
    # referenced by "jump" was actually defined
    $chain_info->{non_empty} = 1;

    # check if the chain is already defined
    unless (exists $chain_info->{was_created} or
            is_netfilter_builtin_chain($table, $chain)) {
        push @$rules, "$rr -N $chain\n";
        $chain_info->{was_created} = 1;
    }

    # check for unknown jump target
    if (defined $action and
        ($action->{type} eq 'jump' or
         $action->{type} eq 'goto') and
        not exists $table_info->{chains}{$action->{chain}}{was_created}) {
        my $chain = $action->{chain};
        push @$rules, "$rr -N $chain\n";
        $table_info->{chains}{$chain}{was_created} = 1;
    }

    # return if this is a policy-only rule
    return
      unless $rule{has_rule};

    shell_append(\$rr, '-A', $chain);

    # modules; copy the hash because we might add automatic protocol
    # modules later
    my %modules;
    if (exists $rule{modules}) {
        %modules = %{$rule{modules}};
        shell_append(\$rr, '-m', $_)
          foreach keys %modules;
    }

    # general iptables options
    shell_append(\$rr, '-s', extract_negation $rule{saddr})
      if defined $rule{saddr};
    shell_append(\$rr, '-d', extract_negation $rule{daddr})
      if defined $rule{daddr};

    shell_append(\$rr, '-i', extract_negation $rule{interface})
      if defined $rule{'interface'};
    shell_append(\$rr, '-o', extract_negation $rule{outerface})
      if defined $rule{'outerface'};

    shell_append(\$rr, '-p', extract_negation $rule{proto})
      if defined $rule{proto};

    if (defined $rule{'fragment'}) {
        shell_append(\$rr, '!')
          unless $rule{fragment} eq 'set';

        shell_append(\$rr, '-f')
    }

    #
    # match module options
    #

    if (defined $rule{proto}) {
        my $proto = $rule{proto};
        $proto = 'icmpv6'
          if $domain eq 'ip6' and $proto eq 'ipv6-icmp';
        $proto = 'mh'
          if $domain eq 'ip6' and $proto eq 'ipv6-mh';

        if (exists $proto_defs{$proto}) {
            my $def = $proto_defs{$proto};
            while (my ($keyword, $k) = each %{$def->{keywords}}) {
                my $key = "protocol__${proto}__$keyword";
                next unless exists $rule{$key};
                my $value = $rule->{$key};

                my $module = $proto eq 'icmpv6' ? 'icmp6' : $proto;
                unless (exists $modules{$module}) {
                    shell_append(\$rr, '-m', $module);
                    $modules{$module} = 1;
                }

                shell_append_option(\$rr, $k, $keyword, $value);
            }
        }

        # special case: --dport and --sport for TCP/UDP
        if ((exists $rule{dport} or exists $rule{sport}) and
            $proto =~ /^(?:tcp|udp|udplite|dccp|sctp)$/) {
            unless (exists $modules{$proto}) {
                shell_append(\$rr, '-m', $proto);
                $modules{$proto} = 1;
            }

            shell_append_option(\$rr, { params => 1,
                                        negation => 1,
                                      }, 'dport', $rule{dport})
              if exists $rule{dport};
            shell_append_option(\$rr, { params => 1,
                                        negation => 1,
                                      }, 'sport', $rule{sport})
              if exists $rule{sport};
        }
    }

    # modules stored in %match_defs
    while (my ($key, $value) = each %rule) {
        next unless $key =~ /^module__(\w+)__([-\w]+)$/;
        my ($module_name, $keyword) = ($1, $2);

        my $def = $match_defs{$module_name}{keywords}{$keyword};
        die unless defined $def;

        shell_append_option(\$rr, $def, $keyword, $value);
    }

    #
    # target options
    #

    if ($action->{type} eq 'jump') {
        shell_append(\$rr, '-j', $action->{chain});
    } elsif ($action->{type} eq 'goto') {
        shell_append(\$rr, '-g', $action->{chain});
    } elsif ($action->{type} eq 'target') {
        shell_append(\$rr, '-j', $action->{target});

        # targets stored in %target_defs

        while (my ($keyword, $value) = each %{$rule{target_options}}) {
            my $def = $target_defs{$action->{target}}{keywords}{$keyword};
            die unless defined $def;

            shell_append_option(\$rr, $def, $keyword, $value);
        }
    } elsif ($action->{type} ne 'nop') {
        die;
    }

    # this line is done
    $rr .= "\n";
    push @$rules, { rule => $rr,
                    script => $rule{script},
                  };
};

sub transform_rule($) {
    my $rule = shift;

    $rule->{proto} = 'icmpv6'
      if $rule->{domain} eq 'ip6' and $rule->{proto} eq 'icmp';
}

sub printrule($) {
    my $rule = shift;

    transform_rule($rule);

    # prints all rules in a hash
    tables($rule);
}


# convert a bunch of internal rule structures in iptables calls,
# unfold arrays during that
sub mkrules($) {
    # compile the list hashes into rules
    my $fw = shift;

    # pack the data in a handy format (list-of-hashes with one kw
    # per level, so we can recurse...
    my @fr;

    foreach my $current (@$fw) {
        while (my ($key, $value) = each %$current) {
            push @fr, [ $key, $value ];
        }
    }

    sub dofr($@) {
        my $rule = shift;
        my $current = shift;

        my ($key, $value_string) = @$current;

        unless (ref $value_string and
                $key ne 'target_options' and
                ref $value_string ne 'params' and
                ref $value_string ne 'multi' and
                ref $value_string ne 'negated') {
                # set this one and recurse
            $rule->{$key} = $value_string;

            if (@_) {
                dofr($rule, @_);
            } else {
                printrule($rule);
            }

            delete $rule->{$key};
        } elsif (ref $value_string eq 'ARRAY') {
            # recurse for every value
            foreach my $value (@$value_string) {
                # set this one and recurse
                $rule->{$key} = $value;

                if (@_) {
                    dofr($rule, @_);
                } else {
                    printrule($rule);
                }
            }

            delete $rule->{$key};
        } elsif (ref $value_string eq 'HASH') {
            # merge hashes
            my $old = $rule->{$key};

            $rule->{$key} = { ( defined $old
                                ? %$old
                                : ()
                              ),
                              %$value_string
                            };

            # recurse
            if (@_) {
                dofr($rule, @_);
            } else {
                printrule($rule);
            }

            # restore old value
            if (defined $old) {
                $rule->{$key} = $old;
            } else {
                delete $rule->{$key};
            }
        } else {
            die ref $value_string;
        }
    }

    dofr({}, @fr);
}

# find an option in the rule stack
sub find_option($$) {
    my ($fw, $key) = @_;

    my $item = (grep { exists $_->{$key} } reverse @$fw)[0];
    return unless defined $item;

    return $item->{$key};
}

sub filter_domains($) {
    my $domains = shift;
    my $result = [];

    foreach my $domain (to_array $domains) {
        next if exists $option{domain}
          and $domain ne $option{domain};

        eval {
            initialize_domain($domain);
        };
        error($@) if $@;

        push @$result, $domain;
    }

    return @$result == 1 ? $result->[0] : $result;
}

# parse tokens from builtin match modules
sub parse_builtin_matches($$$) {
    my ($current, $keyword, $negated_ref) = @_;

    if ($keyword eq 'addr') {
        error("source/destination not declared")
          unless exists $current->{side};
        warning("'$keyword' is deprecated, please use 's$keyword' or 'd$keyword'");
        if ($current->{side} eq 'source') {
            $keyword = 's' . $keyword;
        } elsif ($current->{side} eq 'destination') {
            $keyword = 'd' . $keyword;
        }
    }

    # routing base parameters
    if ($keyword =~ /^(?:interface|if)$/) {
        $current->{interface} = getvalues(undef, undef, allow_negation => 1);
        return 1;
    }
    if ($keyword =~ /^(?:outerface|of)$/) {
        $current->{outerface} = getvalues(undef, undef, allow_negation => 1);
        return 1;
    }
    if ($keyword =~ /^proto(?:col)?$/) {
        $current->{proto} = getvalues(undef, undef, allow_negation => 1);
        return 1;
    }

    if ($keyword =~ /^[sd]addr$/) {
        $current->{$keyword} = getvalues(undef, undef, allow_negation => 1);
        return 1;
    }

    # miscelleanous switches
    if ($keyword eq 'fragment') {
        if ($$negated_ref) {
            $current->{$keyword} = 'unset';
            undef $$negated_ref;
        } else {
            $current->{$keyword} = 'set';
        }
        return 1;
    }

    return;
}

# parse a keyword from a module definition
sub parse_keyword($$$$) {
    my ($fw, $def, $keyword, $negated_ref) = @_;

    my $params = $def->{params};

    my $value;

    my $negated;
    if ($$negated_ref && exists $def->{pre_negation}) {
        $negated = 1;
        undef $$negated_ref;
    }

    unless (defined $params) {
        undef $value;
    } elsif (ref $params && ref $params eq 'CODE') {
        $value = &$params($fw);
    } elsif ($params eq 'm') {
        $value = bless [ to_array getvalues() ], 'multi';
    } elsif ($params =~ /^[a-z]/) {
        if (exists $def->{negation} and not $negated) {
            my $token = peek_token();
            if ($token eq '!') {
                require_next_token;
                $negated = 1;
            }
        }

        my @params;
        foreach my $p (split(//, $params)) {
            if ($p eq 's') {
                push @params, getvar();
            } elsif ($p eq 'c') {
                my @v = to_array getvalues(undef, undef,
                                           non_empty => 1);
                push @params, join(',', @v);
            } else {
                die;
            }
        }

        $value = @params == 1
          ? $params[0]
            : bless \@params, 'params';
    } elsif ($params == 1) {
        if (exists $def->{negation} and not $negated) {
            my $token = peek_token();
            if ($token eq '!') {
                require_next_token;
                $negated = 1;
            }
        }

        $value = getvalues();

        warning("log-prefix is too long; truncating to 29 characters: '$1'")
          if $keyword eq 'log-prefix' && $value =~ s,^(.{29}).+$,$1,;
    } else {
        if (exists $def->{negation} and not $negated) {
            my $token = peek_token();
            if ($token eq '!') {
                require_next_token;
                $negated = 1;
            }
        }

        $value = bless [ map {
            getvar()
        } (1..$params) ], 'params';
    }

    $value = bless [ $value ], 'negated'
      if $negated;

    return $value;
}

# parse options of a module
sub parse_option($$$$$$$) {
    my ($type, $defs, $name, $fw, $current, $keyword, $negated_ref) = @_;

    my $def = $defs->{$name};
    return unless defined $def;

    my $k = $def->{keywords}{$keyword};
    return unless defined $k;

    while (exists $k->{alias}) {
        die if $k->{alias} eq $keyword;
        $keyword = $k->{alias};
        $k = $defs->{$name}{keywords}{$keyword};
        die unless defined $k;
    }

    $current->{"${type}__${name}__${keyword}"}
      = parse_keyword($fw, $k,
                      $keyword, $negated_ref);
    return 1;
}

# parse options for a protocol module definition
sub parse_protocol_options($$$$$) {
    my ($fw, $current, $proto, $keyword, $negated_ref) = @_;

    return parse_option('protocol', \%proto_defs, $proto, $fw, $current,
                        $keyword, $negated_ref);
}

# parse options for a match module definition
sub parse_module_options($$$$$) {
    my ($fw, $current, $modules, $keyword, $negated_ref) = @_;

    # modules stored in %match_defs
    foreach my $name (keys %$modules) {
        parse_option('module', \%match_defs, $name, $fw, $current,
                     $keyword, $negated_ref)
          and do {
              # reset hash
              keys %match_defs;
              return 1;
          }
    }

    return;
}

# parse options for a target module definition
sub parse_target_options($$$$) {
    my ($fw, $current, $target, $keyword) = @_;

    return unless exists $target_defs{$target} &&
      exists $target_defs{$target}{keywords}{$keyword};

    my $k = $target_defs{$target}{keywords}{$keyword};

    while (exists $k->{alias}) {
        die if $k->{alias} eq $keyword;
        $keyword = $k->{alias};
        $k = $target_defs{$target}{keywords}{$keyword};
        die unless defined $k;
    }

    my $negated_dummy;
    $current->{target_options}{$keyword}
      = parse_keyword($fw, $k,
                      $keyword, \$negated_dummy);

    return 1;
}

# the main parser loop: read tokens, convert them into internal rule
# structures
sub enter($@) {
    my $lev = shift;  # current recursion depth
    my @fw = @_; # fwset in list of hashes

    die unless @fw == $lev;

    # enter is the core of the firewall setup, it is a
    # simple parser program that recognizes keywords and
    # retreives parameters to set up the kernel routing
    # chains

    my $base_level = $script->{base_level} || 0;
    die if $base_level > $lev;

    my $current = {};
    push @fw, $current;

    my %modules = map { $_->{modules} ? %{$_->{modules}} : () } @fw;

    # read keywords 1 by 1 and dump into parser
    while (defined (my $keyword = next_token())) {
        # check if the current rule should be negated
        my $negated = $keyword eq '!';
        if ($negated) {
            # negation. get the next word which contains the 'real'
            # rule
            $keyword = getvar();

            error('unexpected end of file after negation')
              unless defined $keyword;
        }

        # the core: parse all data
        SWITCH: for ($keyword)
        {
            # deprecated keyword?
            if (exists $deprecated_keywords{$keyword}) {
                my $new_keyword = $deprecated_keywords{$keyword};
                warning("'$keyword' is deprecated, please use '$new_keyword' instead");
                $keyword = $new_keyword;
            }

            # effectuation operator
            if ($keyword eq ';') {
                my $has_rule = find_option(\@fw, 'has_rule');
                my $action = find_option(\@fw, 'action');
                my $policy = find_option(\@fw, 'policy');
                my $chain = find_option(\@fw, 'chain');

                if ($has_rule and not defined $action) {
                    # something is wrong when a rule was specifiedd,
                    # but no action
                    error('No action defined; did you mean "NOP"?');
                }

                error('No chain defined') unless defined $chain;

                $current->{script} = { filename => $script->{filename},
                                       line => $script->{line},
                                     };

                mkrules(\@fw)
                  if $has_rule or defined $policy;

                # and clean up variables set in this level
                %$current = ();

                next;
            }

            # conditional expression
            if ($keyword eq '@if') {
                unless (eval_bool(getvalues)) {
                    collect_tokens;
                    my $token = peek_token();
                    require_next_token() if $token and $token eq '@else';
                }

                next;
            }

            if ($keyword eq '@else') {
                # hack: if this "else" has not been eaten by the "if"
                # handler above, we believe it came from an if clause
                # which evaluated "true" - remove the "else" part now.
                collect_tokens;
                next;
            }

            # hooks for custom shell commands
            if ($keyword eq 'hook') {
                error('"hook" must be the first token in a command')
                  if keys %$current;

                my $position = getvar();
                my $hooks;
                if ($position eq 'pre') {
                    $hooks = \@pre_hooks;
                } elsif ($position eq 'post') {
                    $hooks = \@post_hooks;
                } else {
                    error("Invalid hook position: '$position'");
                }

                push @$hooks, getvar();

                $keyword = next_token();
                error('";" expected after hook declaration')
                  unless defined $keyword and $keyword eq ';';

                next;
            }

            # recursing operators
            if ($keyword eq '{') {
                # push stack
                my $old_stack_depth = @stack;

                unshift @stack, { auto => { %{$stack[0]{auto} || {}} } };

                # recurse
                enter($lev + 1, @fw);

                # pop stack
                shift @stack;
                die unless @stack == $old_stack_depth;

                # after a block, the command is finished, clear this
                # level
                %$current = ();

                next;
            }

            if ($keyword eq '}') {
                error('Unmatched "}"')
                  if $lev <= $base_level;

                # consistency check: check if they havn't forgotten
                # the ';' before the last statement
                error('Missing semicolon before "}"')
                  if keys %$current;

                # and exit
                return;
            }

            # include another file
            if ($keyword eq '@include' or $keyword eq 'include') {
                my @files = collect_filenames to_array getvalues;
                $keyword = next_token;
                error('Missing ";" - "include FILENAME" must be the last command in a rule')
                  unless defined $keyword and $keyword eq ';';

                foreach my $filename (@files) {
                    # save old script, open new script
                    my $old_script = $script;
                    open_script($filename);
                    $script->{base_level} = $lev + 1;

                    # push stack
                    my $old_stack_depth = @stack;

                    my $stack = {};

                    if (@stack > 0) {
                        # include files may set variables for their parent
                        $stack->{vars} = ($stack[0]{vars} ||= {});
                        $stack->{functions} = ($stack[0]{functions} ||= {});
                        $stack->{auto} = { %{ $stack[0]{auto} || {} } };
                    }

                    unshift @stack, $stack;

                    # parse the script
                    enter($lev + 1, @fw);

                    # pop stack
                    shift @stack;
                    die unless @stack == $old_stack_depth;

                    # restore old script
                    $script = $old_script;
                }

                next;
            }

            # definition of a variable or function
            if ($keyword eq '@def' or $keyword eq 'def') {
                error('"def" must be the first token in a command')
                  if keys %$current;

                my $type = require_next_token();
                if ($type eq '$') {
                    my $name = require_next_token();
                    error('invalid variable name')
                      unless $name =~ /^\w+$/;

                    $keyword = require_next_token();
                    error('"=" expected after variable name')
                      unless $keyword eq '=';

                    my $value = getvalues(undef, undef, allow_negation => 1);

                    $keyword = next_token();
                    error('";" expected after variable declaration')
                      unless defined $keyword and $keyword eq ';';

                    $stack[0]{vars}{$name} = $value
                      unless exists $stack[-1]{vars}{$name};
                } elsif ($type eq '&') {
                    my $name = require_next_token();
                    error('invalid function name')
                      unless $name =~ /^\w+$/;

                    my @params;
                    my $token = next_token();
                    error('function parameter list or "()" expected')
                      unless defined $token and $token eq '(';
                    while (1) {
                        $token = require_next_token();
                        last if $token eq ')';

                        if (@params > 0) {
                            error('"," expected')
                              unless $token eq ',';

                            $token = require_next_token();
                        }

                        error('"$" and parameter name expected')
                          unless $token eq '$';

                        $token = require_next_token();
                        error('invalid function parameter name')
                          unless $token =~ /^\w+$/;

                        push @params, $token;
                    }

                    my %function;

                    $function{params} = \@params;

                    $keyword = require_next_token;
                    error('"=" expected')
                      unless $keyword eq '=';

                    my $tokens = collect_tokens();
                    $function{block} = 1 if grep { $_ eq '{' } @$tokens;
                    $function{tokens} = $tokens;

                    $stack[0]{functions}{$name} = \%function
                      unless exists $stack[-1]{functions}{$name};
                } else {
                    error('"$" (variable) or "&" (function) expected');
                }

                next;
            }

            # def references
            if ($keyword eq '$') {
                error('variable references are only allowed as keyword parameter');
            }

            if ($keyword eq '&') {
                my $name = require_next_token;
                error('function name expected')
                  unless $name =~ /^\w+$/;

                my $function;
                foreach (@stack) {
                    $function = $_->{functions}{$name};
                    last if defined $function;
                }
                error("no such function: \&$name")
                  unless defined $function;

                my $paramdef = $function->{params};
                die unless defined $paramdef;

                my @params = get_function_params(allow_negation => 1);

                error("Wrong number of parameters for function '\&$name': "
                      . @$paramdef . " expected, " . @params . " given")
                  unless @params == @$paramdef;

                my %vars;
                for (my $i = 0; $i < @params; $i++) {
                    $vars{$paramdef->[$i]} = $params[$i];
                }

                if ($function->{block}) {
                    # block {} always ends the current rule, so if the
                    # function contains a block, we have to require
                    # the calling rule also ends here
                    my $token = next_token();
                    error("';' expected after block function call '\&$name'")
                      unless defined $token and $token eq ';';
                }

                my @tokens = @{$function->{tokens}};
                for (my $i = 0; $i < @tokens; $i++) {
                    if ($tokens[$i] eq '$' and $i + 1 < @tokens and
                        exists $vars{$tokens[$i + 1]}) {
                        my @value = to_array($vars{$tokens[$i + 1]});
                        @value = ('(', @value, ')')
                          unless @tokens == 1;
                        splice(@tokens, $i, 2, @value);
                        $i += @value - 2;
                    } elsif ($tokens[$i] =~ m,^"(.*)"$,) {
                        $tokens[$i] =~ s,\$(\w+),exists $vars{$1} ? $vars{$1} : "\$$1",eg;
                    }
                }

                unshift @{$script->{tokens}}, @tokens;

                next;
            }

            # where to put the rule?
            if ($keyword eq 'domain') {
                error('Domain is already specified')
                  if exists $current->{domain};

                $current->{domain} = $stack[0]{auto}{DOMAIN}
                  = filter_domains(getvalues());

                next;
            }

            if ($keyword eq 'table') {
                error('Table is already specified')
                  if exists $current->{table};
                $current->{table} = $stack[0]{auto}{TABLE} = getvalues();

                my $domain = find_option(\@fw, 'domain');
                $current->{domain} = $domain = filter_domains('ip')
                  unless defined $domain;

                next;
            }

            if ($keyword eq 'chain') {
                error('Chain is already specified')
                  if exists $current->{chain};
                $current->{chain} = $stack[0]{auto}{CHAIN} = getvalues();

                # ferm 1.1 compatibility: uppercase built-in chain
                # names
                foreach (ref $current->{chain} ? @{$current->{chain}} : $current->{chain}) {
                    s/^(?:input|forward|output|prerouting|postrouting)$/uc $&/e
                      and warning('Please write built-in chain names in upper case');
                }

                $current->{domain} = filter_domains('ip')
                  unless defined find_option(\@fw, 'domain');
                $current->{table} = 'filter'
                  unless defined find_option(\@fw, 'table');

                next;
            }

            # policy for built-in chain
            if ($keyword eq 'policy') {
                my $domains = find_option(\@fw, 'domain');
                my $tables = find_option(\@fw, 'table');
                my $chains = find_option(\@fw, 'chain');

                error('Chain must be specified')
                  unless defined $chains;

                my $policy = uc getvar();
                error("Invalid policy target: $policy")
                  unless $policy =~ /^(?:ACCEPT|DROP)$/;

                foreach my $domain (to_array $domains) {
                    foreach my $table (to_array $tables) {
                        my $chains_info = $domains{$domain}{tables}{$table}{chains} ||= {};

                        foreach my $chain (to_array $chains) {
                            error("cannot set the policy for non-builtin chain '$chain'")
                              unless is_netfilter_builtin_chain($table, $chain);

                            if (exists $chains_info->{$chain}{policy}) {
                                warning('policy for this chain is specified for the second time');
                            } else {
                                $chains_info->{$chain}{policy} = $policy;
                                $chains_info->{$chain}{set_policy} = 1;
                            }
                        }
                    }
                }

                $current->{policy} = $policy;
                next;
            }

            # create a subchain
            if ($keyword eq '@subchain' or $keyword eq 'subchain') {
                error('No rule specified before "@subchain"')
                  unless find_option(\@fw, 'has_rule');

                my $subchain;
                $keyword = next_token();

                if ($keyword =~ /^(["'])(.*)\1$/s) {
                    $subchain = $2;
                    $keyword = next_token();
                } else {
                    $subchain = 'ferm_auto_' . ++$auto_chain;
                }

                error('"{" or chain name expected after "sub"')
                  unless $keyword eq '{';

                # create a deep copy of @fw, only containing values
                # which must be in the subchain
                my @fw2;
                foreach my $fw (@fw) {
                    my $fw2 = {};
                    foreach my $key (qw(domain table proto)) {
                        my $value = $fw->{$key};
                        next unless defined $value;
                        $value = ref $value
                          ? ( ref $value eq 'HASH'
                              ? {%$value}
                              : [@$value]
                            )
                            : $value;
                        $fw2->{$key} = $value;
                    }
                    push @fw2, $fw2;
                }

                $fw2[-1]->{chain} = $fw2[-1]->{auto}{CHAIN} = $subchain;

                # enter the block
                enter($lev + 1, @fw2);

                # now handle the parent - it's a jump to the sub chain
                $current->{action} = { type => 'jump',
                                       chain => $subchain,
                                     };

                $current->{script} = { filename => $script->{filename},
                                       line => $script->{line},
                                     };

                mkrules(\@fw);

                # and clean up variables set in this level
                %$current = ();

                next;
            }

            # everything else must be part of a "real" rule, not just
            # "policy only"
            $current->{has_rule}++;

            # choose a side
            if ($keyword =~ /^(?:source|src)$/) {
                warning("'$keyword' is deprecated, please use 'saddr' or 'sport'");
                $current->{side} = 'source';
                next;
            }

            if ($keyword =~ /^(?:destination|dest)$/) {
                warning("'$keyword' is deprecated, please use 'daddr' or 'dport'");
                $current->{side} = 'destination';
                next;
            }

            # extended parameters:
            if ($keyword =~ /^mod(?:ule)?$/) {
                my $domains = find_option(\@fw, 'domain');

                foreach my $module (to_array getvalues) {
                    $current->{modules}{$module} = 1;
                    $modules{$module} = 1;
                }

                next;
            }

            parse_builtin_matches($current, $keyword, \$negated)
              and next;

            ###
            # actions
            #

            # jump action
            if ($keyword eq 'jump') {
                error('There can only one action per rule')
                  if exists $current->{action};
                warning('Please declare the policy in a separate statement')
                  if find_option(\@fw, 'policy');
                my $chain = getvar();
                if (is_netfilter_core_target($chain) or
                    is_netfilter_module_target($chain)) {
                    $current->{action} = { type => 'target',
                                           target => $chain,
                                         };
                } else {
                    $current->{action} = { type => 'jump',
                                           chain => $chain,
                                         };
                }
                next;
            };

            # goto action
            if ($keyword eq 'realgoto') {
                error('There can only one action per rule')
                  if exists $current->{action};
                warning('Please declare the policy in a separate statement')
                  if find_option(\@fw, 'policy');
                $current->{action} = { type => 'goto',
                                       chain => getvar(),
                                     };
                next;
            };

            # action keywords
            if (is_netfilter_core_target($keyword)) {
                error('There can only one action per rule')
                  if exists $current->{action};
                warning('Please declare the policy in a separate statement')
                  if find_option(\@fw, 'policy');
                $current->{action} = { type => 'target',
                                       target => $keyword,
                                     };
                next;
            }

            if ($keyword eq 'NOP') {
                error('There can only one action per rule')
                  if exists $current->{action};
                warning('Please declare the policy in a separate statement')
                  if find_option(\@fw, 'policy');
                $current->{action} = { type => 'nop',
                                     };
                next;
            }

            if (is_netfilter_module_target($keyword)) {
                error('There can only one action per rule')
                  if exists $current->{action};
                warning('Please declare the policy in a separate statement')
                  if find_option(\@fw, 'policy');

                if ($keyword eq 'TCPMSS') {
                    my $protos = find_option(\@fw, 'proto');
                    error('No protocol specified before TCPMSS')
                      unless defined $protos;
                    foreach my $proto (to_array $protos) {
                        error('TCPMSS not available for protocol "$proto"')
                          unless $proto eq 'tcp';
                    }
                }

                $current->{action} = { type => 'target',
                                       target => $keyword,
                                     };
                next;
            }

            ###
            # protocol specific options
            #

            my $proto = find_option(\@fw, 'proto');
            if (defined $proto and not ref $proto) {
                $proto = 'icmpv6' if $proto eq 'ipv6-icmp';
                $proto = 'mh' if $proto eq 'ipv6-mh';

                if ($proto eq 'icmp') {
                    my $domains = find_option(\@fw, 'domain');
                    $proto = 'icmpv6' if not ref $domains and $domains eq 'ip6';
                }

                parse_protocol_options(\@fw, $current, $proto, $keyword, \$negated)
                  and next;
            }

            # port switches
            if ($keyword eq 'port') {
                error("source/destination not declared")
                  unless exists $current->{side};
                warning("'$keyword' is deprecated, please use 's$keyword' or 'd$keyword'");
                if ($current->{side} eq 'source') {
                    $keyword = 's' . $keyword;
                } elsif ($current->{side} eq 'destination') {
                    $keyword = 'd' . $keyword;
                }
            }

            if ($keyword =~ /^[sd]port$/) {
                error('To use sport or dport, you have to specify "proto tcp" or "proto udp" first')
                  unless defined $proto and grep { /^(?:tcp|udp|udplite|dccp|sctp)$/ } to_array $proto;

                $current->{$keyword} = getvalues(undef, undef,
                                                 allow_negation => 1);
                next;
            }

            ###
            # module specific options
            #

            if ($option{automod} and exists $automod{$keyword}) {
                # suport the deprecated 'automod' option
                $current->{modules}{$automod{$keyword}} = 1;
                $modules{$automod{$keyword}} = 1;
            }

            if (keys %modules) {
                parse_module_options(\@fw, $current, \%modules, $keyword, \$negated)
                  and next;
            }

            ###
            # target specific options
            #

            my $action = find_option(\@fw, 'action');
            if (defined $action and $action->{type} eq 'target') {
                parse_target_options(\@fw, $current,
                                     $action->{target}, $keyword);
                next;
            }

            # default
            error("Unrecognized keyword: $keyword");
        }

        # if the rule didn't reset the negated flag, it's not
        # supported
        error("Doesn't support negation: $keyword")
          if $negated;
    }

    error('Missing "}" at end of file')
      if $lev > $base_level;

    # consistency check: check if they havn't forgotten
    # the ';' before the last statement
    error("Missing semicolon before end of file")
      if keys %$current;
}

sub check() {
    while (my ($domain_name, $domain) = each %domains) {
        while (my ($table_name, $table_info) = each %{$domain->{tables}}) {
            while (my ($chain_name, $chain) = each %{$table_info->{chains}}) {
                warning("chain $chain_name (domain $domain_name, table $table_name) was referenced, but not declared")
                  if $chain->{was_created} and not $chain->{non_empty};
            }
        }
    }
}

sub execute_slow($$) {
    my ($domain, $rules) = @_;

    my $status;
    foreach (reset_domain($domain), @$rules) {
        my $script;

        if (ref) {
            $script = $_->{script};
            $_ = $_->{rule};
        }

        s/^\s+//s;
        print LINES $_
          if $option{lines};
        next if $option{noexec};
        next if /^#/;

        my $ret = system($_);
        unless ($ret == 0) {
            if ($? == -1) {
                print STDERR "failed to execute: $!\n";
                exit 1;
            } elsif ($? & 0x7f) {
                printf STDERR "child died with signal %d\n", $? & 0x7f;
                $status = 1;
            } else {
                print STDERR "(rule declared in $script->{filename}:$script->{line})\n"
                  if defined $script;
                $status = $? >> 8;
            }
        }
    }

    return $status;
}

sub rules_to_save($$) {
    my ($domain, $rules) = @_;

    # parse the current ruleset, ignore -X and -F, handle policies and
    # custom chains
    my %policies;
    my %rules;
    foreach my $rule (reset_domain($domain), @$rules) {
        $rule = $rule->{rule}
          if ref $rule;

        $rule =~ s/^\S+\s+//;
        my $table = $rule =~ s/-t\s+(\w+)\s*//
          ? $1 : 'filter';
        if ($rule =~ /-P\s+(\S+)\s+(\w+)\s*/) {
            $policies{$table}{$1} = $2;
        } elsif ($rule =~ /-A\s+(\w+)/) {
            push @{$rules{$table}{$1}}, $rule;
        } elsif ($rule =~ /-N\s+(\S+)\s*/) {
            $policies{$table}{$1} = '-';
        }
    }

    # convert this into an iptables-save text
    my $result = "# Generated by ferm $VERSION on " . localtime() . "\n";

    foreach my $table (qw(nat filter mangle raw)) {
        my $policies = $policies{$table};
        my $r = $rules{$table};

        next
          unless defined $policies or defined $r;

        # select table
        $result .= '*' . $table . "\n";

        # create chains / set policy
        if (defined $policies) {
            foreach my $chain (sort keys %$policies) {
                my $policy = $policies->{$chain};
                $result .= ":$chain $policy\ [0:0]\n";
            }
        }

        # dump rules
        if (defined $r) {
            foreach my $chain (sort keys %$r) {
                my $rs = $r->{$chain};
                foreach (@$rs) {
                    $result .= $_;
                }
            }
        }

        # do it
        $result .= "COMMIT\n";
   }

    return $result;
}

sub restore_domain($$) {
    my ($domain, $save) = @_;

    my $path = $domains{$domain}{tools}{'tables-restore'};

    local *RESTORE;
    open RESTORE, "|$path"
      or die "Failed to run $path: $!\n";

    print RESTORE $save;

    close RESTORE
      or die "Failed to run $path\n";
}

sub execute_fast($$) {
    my ($domain, $save) = @_;

    if ($option{lines}) {
        print LINES "$domains{$domain}{tools}{'tables-restore'} <<EOT\n"
          if $option{shell};
        print LINES $save;
        print LINES "EOT\n"
          if $option{shell};
    }

    return if $option{noexec};

    eval {
        restore_domain($domain, $save);
    };
    if ($@) {
        print STDERR $@;
        return 1;
    }

    return;
}

sub rollback() {
    my $error;
    foreach my $domain (keys %rules) {
        my $reset = '';
        while (my ($table, $table_info) = each %{$domains{$domain}{tables}}) {
            my $reset_chain = '';
            foreach my $chain (keys %{$table_info->{chains}{$table}}) {
                next unless is_netfilter_builtin_chain($table, $chain);
                $reset_chain .= ":${chain} ACCEPT [0:0]\n";
            }
            $reset .= "*${table}\n${reset_chain}COMMIT\n"
              if length $reset_chain;
        }

        $reset .= $domains{$domain}{previous}
          if defined $domains{$domain}{previous};

        restore_domain($domain, $reset);
    }

    print STDERR "\nFirewall rules rolled back.\n" unless $error;
    exit 1;
}

sub alrm_handler {
    # do nothing, just interrupt a system call
}

sub confirm_rules() {
    $SIG{ALRM} = \&alrm_handler;

    alarm(5);

    print STDERR "\n"
      . "ferm has applied the new firewall rules.\n"
        . "Please type 'yes' to confirm:\n";
    STDERR->flush();

    alarm(30);

    my $line = '';
    STDIN->sysread($line, 3);

    eval {
        require POSIX;
        POSIX::tcflush(*STDIN, 2);
    };
    print STDERR "$@" if $@;

    $SIG{ALRM} = 'DEFAULT';

    return $line eq 'yes';
}

# end of ferm

__END__

=head1 NAME

ferm - a firewall rule parser for linux

=head1 SYNOPSIS

B<ferm> I<options> I<inputfiles>

=head1 OPTIONS

 -n, --noexec      Do not execute the rules, just simulate
 -F, --flush       Flush all netfilter tables managed by ferm
 -l, --lines       Show all rules that were created
 -i, --interactive Interactive mode: revert if user does not confirm
 --remote          Remote mode; ignore host specific configuration.
                   This implies --noexec and --lines.
 -V, --version     Show current version number
 -h, --help        Look at this text
 --fast            Generate an iptables-save file, used by iptables-restore
 --shell           Generate a shell script which calls iptables-restore
 --domain {ip|ip6} Handle only the specified domain
 --def '$name=v'   Override a variable

=cut
