src/ferm

   1 #!/usr/bin/perl
   2
   3 #
   4 # ferm, a firewall setup program that makes firewall rules easy!
   5 #
   6 # Copyright (C) 2001-2007 Auke Kok, Max Kellermann
   7 #
   8 # Comments, questions, greetings and additions to this program
   9 # may be sent to <ferm@foo-projects.org>
  10 #
  11
  12 #
  13 # This program is free software; you can redistribute it and/or modify
  14 # it under the terms of the GNU General Public License as published by
  15 # the Free Software Foundation; either version 2 of the License, or
  16 # (at your option) any later version.
  17 #
  18 # This program is distributed in the hope that it will be useful,
  19 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 # GNU General Public License for more details.
  22 #
  23 # You should have received a copy of the GNU General Public License
  24 # along with this program; if not, write to the Free Software
  25 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  26 #
  27
  28 # $Id$
  29
  30 BEGIN {
  31     eval { require strict; import strict; };
  32     $has_strict = not $@;
  33     if ($@) {
  34         # we need no vars.pm if there is not even strict.pm
  35         $INC{'vars.pm'} = 1;
  36         *vars::import = sub {};
  37     }
  38
  39     eval { require Getopt::Long; import Getopt::Long; };
  40     $has_getopt = not $@;
  41 }
  42
  43 use vars qw($has_strict $has_getopt);
  44
  45 use vars qw($DATE $VERSION);
  46
  47 # subversion keyword magic
  48 $DATE = '$Date$' =~ m,(\d{4})-(\d\d)-(\d\d), ? $1.$2.$3 : '';
  49
  50 $VERSION = '2.0';
  51 $VERSION .= '~svn' . $DATE;
  52
  53 ## interface variables
  54 # %option = command line and other options
  55 use vars qw(%option);
  56
  57 ## hooks
  58 use vars qw(@pre_hooks @post_hooks);
  59
  60 ## parser variables
  61 # $script: current script file
  62 # @stack = ferm's parser stack containing local variables
  63 # $auto_chain = index for the next auto-generated chain
  64 use vars qw($script %rules @stack $auto_chain);
  65
  66 ## netfilter variables
  67 # %domains = state information about all domains ("ip" and "ip6")
  68 # - initialized: domain initialization is done
  69 # - tools: hash providing the paths of the domain's tools
  70 # - previous: save file of the previous ruleset, for rollback
  71 # - reset: has this domain already been reset?
  72 # - tables{$name}: ferm state information about tables
  73 #   - chains{$chain}: ferm state information about the chains
  74 #     - builtin: whether this is a built-in chain
  75 #     - was_created: custom chain has been created
  76 #     - non_empty: are there rules for this chain?
  77 use vars qw(%domains);
  78
  79 ## constants
  80 use vars qw(%deprecated_keywords);
  81
  82 # keywords from ferm 1.1 which are deprecated, and the new one; these
  83 # are automatically replaced, and a warning is printed
  84 %deprecated_keywords = ( goto => 'jump',
  85                        );
  86
  87 # these hashes provide the Netfilter module definitions
  88 use vars qw(%proto_defs %match_defs %target_defs);
  89
  90 #
  91 # This subsubsystem allows you to support (most) new netfilter modules
  92 # in ferm.  Add a call to one of the "add_XY_def()" functions below.
  93 #
  94 # Ok, now about the cryptic syntax: the function "add_XY_def()"
  95 # registers a new module.  There are three kinds of modules: protocol
  96 # module (e.g. TCP, ICMP), match modules (e.g. state, physdev) and
  97 # target modules (e.g. DNAT, MARK).
  98 #
  99 # The first parameter is always the module name which is passed to
 100 # iptables with "-p", "-m" or "-j" (depending on which kind of module
 101 # this is).
 102 #
 103 # After that, you add an encoded string for each option the module
 104 # supports.  This is where it becomes tricky.
 105 #
 106 # foo           defaults to an option with one argument (which may be a ferm
 107 #               array)
 108 #
 109 # foo*0         option without any arguments
 110 #
 111 # foo=s         one argument which must not be a ferm array ('s' stands for
 112 #               'scalar')
 113 #
 114 # to-source=a   one argument, may be a ferm array ('a'='array'); this forces
 115 #               ferm to accept arrays, even in a target declaration; example:
 116 #               to-source (1.2.3.4 5.6.7.8)  translates to:
 117 #               --to-source 1.2.3.4 --to-source 5.6.7.8
 118 #
 119 # ctstate=c     one argument, if it's an array, pass it to iptables as a
 120 #               single comma separated value; example:
 121 #                 ctstate (ESTABLISHED RELATED)  translates to:
 122 #                 --ctstate ESTABLISHED,RELATED
 123 #
 124 # foo=sac       three arguments: scalar, array, comma separated; you may
 125 #               concatenate more than one letter code after the '='
 126 #
 127 # foo&bar       one argument; call the perl function '&bar()' which parses
 128 #               the argument
 129 #
 130 # !foo          negation is allowed and the '!' is written before the keyword
 131 #
 132 # foo!          same as above, but '!' is after the keyword and before the
 133 #               parameters
 134 #
 135 # to:=to-destination    makes "to" an alias for "to-destination"; you have
 136 #                       to add a declaration for option "to-destination"
 137 #
 138
 139 # add a module definition
 140 sub add_def_x {
 141     my $defs = shift;
 142     my $domain_family = shift;
 143     my $name = shift;
 144     die if exists $defs->{$domain_family}{$name};
 145     my $def = $defs->{$domain_family}{$name} = {};
 146     foreach (@_) {
 147         my $keyword = $_;
 148         my $k = {};
 149
 150         my $params = 1;
 151         $params = $1 if $keyword =~ s,\*(\d+)$,,;
 152         $params = $1 if $keyword =~ s,=([acs]+)$,,;
 153         if ($keyword =~ s,&(\S+)$,,) {
 154             $params = eval "\\&$1";
 155             die $@ if $@;
 156         }
 157         $k->{params} = $params if $params;
 158
 159         $k->{negation} = $k->{pre_negation} = 1 if $keyword =~ s,^!,,;
 160         $k->{negation} = 1 if $keyword =~ s,!$,,;
 161
 162         $k->{alias} = $1 if $keyword =~ s,:=(\S+)$,,;
 163
 164         $def->{keywords}{$keyword} = $k;
 165     }
 166
 167     return $def;
 168 }
 169
 170 # add a protocol module definition
 171 sub add_proto_def_x(@) {
 172     add_def_x(\%proto_defs, @_);
 173 }
 174
 175 # add a match module definition
 176 sub add_match_def_x(@) {
 177     add_def_x(\%match_defs, @_);
 178 }
 179
 180 # add a target module definition
 181 sub add_target_def_x(@) {
 182     add_def_x(\%target_defs, @_);
 183 }
 184
 185 sub add_def {
 186     my $defs = shift;
 187     add_def_x($defs, 'ip', @_);
 188 }
 189
 190 # add a protocol module definition
 191 sub add_proto_def(@) {
 192     add_def(\%proto_defs, @_);
 193 }
 194
 195 # add a match module definition
 196 sub add_match_def(@) {
 197     add_def(\%match_defs, @_);
 198 }
 199
 200 # add a target module definition
 201 sub add_target_def(@) {
 202     add_def(\%target_defs, @_);
 203 }
 204
 205 add_proto_def 'dccp', qw(dccp-types!=c dccp-option!);
 206 add_proto_def 'mh', qw(mh-type!);
 207 add_proto_def 'icmp', qw(icmp-type!);
 208 add_proto_def 'icmpv6', qw(icmpv6-type! icmp-type:=icmpv6-type);
 209 add_proto_def 'sctp', qw(chunk-types!=sc);
 210 add_proto_def 'tcp', qw(tcp-flags!=cc !syn*0 tcp-option! mss);
 211 add_proto_def 'udp', qw();
 212
 213 add_match_def '',
 214   # --protocol
 215   qw(protocol! proto:=protocol),
 216   # --source, --destination
 217   qw(source! saddr:=source destination! daddr:=destination),
 218   # --in-interface
 219   qw(in-interface! interface:=in-interface if:=in-interface),
 220   # --out-interface
 221   qw(out-interface! outerface:=out-interface of:=out-interface),
 222   # --fragment
 223   qw(!fragment*0);
 224 add_match_def 'account', qw(aaddr=s aname=s ashort*0);
 225 add_match_def 'addrtype', qw(src-type dst-type);
 226 add_match_def 'ah', qw(ahspi! ahlen! ahres*0);
 227 add_match_def 'comment', qw(comment=s);
 228 add_match_def 'condition', qw(condition!);
 229 add_match_def 'connbytes', qw(!connbytes connbytes-dir connbytes-mode);
 230 add_match_def 'connlimit', qw(!connlimit-above connlimit-mask);
 231 add_match_def 'connmark', qw(mark);
 232 add_match_def 'conntrack', qw(ctstate=c ctproto ctorigsrc! ctorigdst!),
 233   qw(ctreplsrc! ctrepldst! ctstatus ctexpire=s);
 234 add_match_def 'dscp', qw(dscp dscp-class);
 235 add_match_def 'dst', qw(dst-len!=s dst-opts=c);
 236 add_match_def 'ecn', qw(ecn-tcp-cwr*0 ecn-tcp-ece*0 ecn-ip-ect);
 237 add_match_def 'esp', qw(espspi!);
 238 add_match_def 'eui64';
 239 add_match_def 'frag', qw(fragid! fraglen! fragres*0 fragmore*0 fragfirst*0 fraglast*0);
 240 add_match_def 'fuzzy', qw(lower-limit=s upper-limit=s);
 241 add_match_def 'hbh', qw(hbh-len! hbh-opts=c);
 242 add_match_def 'helper', qw(helper);
 243 add_match_def 'hl', qw(hl-eq! hl-lt=s hl-gt=s);
 244 add_match_def 'length', qw(length!);
 245 add_match_def 'hashlimit', qw(hashlimit=s hashlimit-burst=s hashlimit-mode=s hashlimit-name=s),
 246   qw(hashlimit-htable-size=s hashlimit-htable-max=s),
 247   qw(hashlimit-htable-expire=s hashlimit-htable-gcinterval=s);
 248 add_match_def 'iprange', qw(!src-range !dst-range);
 249 add_match_def 'iplimit', qw(!iplimit-above=s iplimit-mask=s);
 250 add_match_def 'ipv6header', qw(header!=c soft*0);
 251 add_match_def 'limit', qw(limit=s limit-burst=s);
 252 add_match_def 'mac', qw(mac-source!);
 253 add_match_def 'mark', qw(mark);
 254 add_match_def 'multiport', qw(source-ports!&multiport_params),
 255   qw(destination-ports!&multiport_params ports!&multiport_params);
 256 add_match_def 'nth', qw(every counter start packet);
 257 add_match_def 'owner', qw(uid-owner gid-owner pid-owner sid-owner cmd-owner);
 258 add_match_def 'physdev', qw(physdev-in! physdev-out!),
 259   qw(!physdev-is-in*0 !physdev-is-out*0 !physdev-is-bridged*0);
 260 add_match_def 'pkttype', qw(pkt-type),
 261 add_match_def 'policy',
 262   qw(dir pol strict*0 reqid spi proto mode tunnel-src tunnel-dst next*0);
 263 add_match_def 'psd', qw(psd-weight-threshold psd-delay-threshold),
 264   qw(psd-lo-ports-weight psd-hi-ports-weight);
 265 add_match_def 'quota', qw(quota=s);
 266 add_match_def 'random', qw(average);
 267 add_match_def 'realm', qw(realm!);
 268 add_match_def 'recent', qw(name=s !set*0 !rcheck*0 !update*0 !seconds !hitcount rttl*0);
 269 add_match_def 'rt', qw(rt-type! rt-segsleft! rt-len! rt-0-res*0 rt-0-addrs=c rt-0-not-strict*0);
 270 add_match_def 'set', qw(set=sc);
 271 add_match_def 'state', qw(state=c);
 272 add_match_def 'statistic', qw(mode=s probability=s every=s packet=s);
 273 add_match_def 'tcpmss', qw(!mss);
 274 add_match_def 'time', qw(timestart=s timestop=s days=c datestart=s datestop=s);
 275 add_match_def 'tos', qw(!tos);
 276 add_match_def 'ttl', qw(ttl-eq ttl-lt=s ttl-gt=s);
 277
 278 add_target_def 'BALANCE', qw(to-destination to:=to-destination);
 279 add_target_def 'CLASSIFY', qw(set-class);
 280 add_target_def 'CONNMARK', qw(set-mark save-mark*0 restore-mark*0 mask);
 281 add_target_def 'CONNSECMARK', qw(save*0 restore*0);
 282 add_target_def 'DNAT', qw(to-destination to:=to-destination);
 283 add_target_def 'DSCP', qw(set-dscp set-dscp-class);
 284 add_target_def 'ECN', qw(ecn-tcp-remove*0);
 285 add_target_def 'HL', qw(hl-set hl-dec hl-inc);
 286 add_target_def 'LOG', qw(log-level log-prefix),
 287   qw(log-tcp-sequence*0 log-tcp-options*0 log-ip-options*0 log-uid*0);
 288 add_target_def 'MARK', qw(set-mark);
 289 add_target_def 'MASQUERADE', qw(to-ports);
 290 add_target_def 'MIRROR';
 291 add_target_def 'NETMAP', qw(to);
 292 add_target_def 'NFLOG', qw(nflog-group nflog-prefix nflog-range nflog-threshold);
 293 add_target_def 'NFQUEUE', qw(queue-num);
 294 add_target_def 'NOTRACK';
 295 add_target_def 'REDIRECT', qw(to-ports);
 296 add_target_def 'REJECT', qw(reject-with);
 297 add_target_def 'ROUTE', qw(oif iif gw continue*0 tee*0);
 298 add_target_def 'SAME', qw(to nodst*0);
 299 add_target_def 'SECMARK', qw(selctx);
 300 add_target_def 'SET', qw(add-set=sc del-set=sc);
 301 add_target_def 'SNAT', qw(to-source=a to:=to-source);
 302 add_target_def 'TARPIT';
 303 add_target_def 'TCPMSS', qw(set-mss clamp-mss-to-pmtu*0);
 304 add_target_def 'TOS', qw(set-tos);
 305 add_target_def 'TRACE';
 306 add_target_def 'TTL', qw(ttl-set ttl-dec ttl-inc);
 307 add_target_def 'ULOG', qw(ulog-nlgroup ulog-prefix ulog-cprange ulog-qthreshold);
 308
 309 add_match_def_x 'arp', '',
 310   # ip
 311   qw(source-ip! destination-ip! saddr:=source-ip daddr:=destination-ip),
 312   # mac
 313   qw(source-mac! destination-mac!),
 314   # --in-interface
 315   qw(in-interface! interface:=in-interface if:=in-interface),
 316   # --out-interface
 317   qw(out-interface! outerface:=out-interface of:=out-interface),
 318   # misc
 319   qw(h-length=s opcode=s h-type=s proto-type=s),
 320   qw(mangle-ip-s=s mangle-ip-d=s mangle-mac-s=s mangle-mac-d=s mangle-target=s);
 321
 322 add_match_def_x 'eb', '',
 323   # protocol
 324   qw(protocol! proto:=protocol),
 325   # --in-interface
 326   qw(in-interface! interface:=in-interface if:=in-interface),
 327   # --out-interface
 328   qw(out-interface! outerface:=out-interface of:=out-interface),
 329   # logical interface
 330   qw(logical-in! logical-out!),
 331   # --source, --destination
 332   qw(source! saddr:=source destination! daddr:=destination),
 333   # 802.3
 334   qw(802_3-sap! 802_3-type!),
 335   # arp
 336   qw(arp-opcode! arp-htype!=ss arp-ptype!=ss),
 337   qw(arp-ip-src! arp-ip-dst! arp-mac-src! arp-mac-dst!),
 338   # ip
 339   qw(ip-source! ip-destination! ip-tos! ip-protocol! ip-sport! ip-dport!),
 340   # mark_m
 341   qw(mark!),
 342   # pkttype
 343   qw(pkttype-type!),
 344   # stp
 345   qw(stp-type! stp-flags! stp-root-prio! stp-root-addr! stp-root-cost!),
 346   qw(stp-sender-prio! stp-sender-addr! stp-port! stp-msg-age! stp-max-age!),
 347   qw(stp-hello-time! stp-forward-delay!),
 348   # vlan
 349   qw(vlan-id! vlan-prio! vlan-encap!),
 350   # log
 351   qw(log*0 log-level=s log-prefix=s log-ip*0 log-arp*0);
 352
 353 add_target_def_x 'eb', 'arpreply', qw(arpreply-mac arpreply-target);
 354 add_target_def_x 'eb', 'dnat', qw(to-destination dnat-target);
 355 add_target_def_x 'eb', 'mark', qw(set-mark mark-target);
 356 add_target_def_x 'eb', 'redirect', qw(redirect-target);
 357 add_target_def_x 'eb', 'snat', qw(to-source snat-target);
 358
 359 # parameter parser for ipt_multiport
 360 sub multiport_params {
 361     my $fw = shift;
 362
 363     # multiport only allows 15 ports at a time. For this
 364     # reason, we do a little magic here: split the ports
 365     # into portions of 15, and handle these portions as
 366     # array elements
 367
 368     my $proto = find_option($fw, 'builtin____protocol');
 369     error('To use multiport, you have to specify "proto tcp" or "proto udp" first')
 370       unless defined $proto and grep { /^(?:tcp|udp|udplite)$/ } to_array($proto);
 371
 372     my $value = getvalues(undef, undef,
 373                           allow_negation => 1,
 374                           allow_array_negation => 1);
 375     if (ref $value and ref $value eq 'ARRAY') {
 376         my @value = @$value;
 377         my @params;
 378
 379         while (@value) {
 380             push @params, join(',', splice(@value, 0, 15));
 381         }
 382
 383         return @params == 1
 384           ? $params[0]
 385             : \@params;
 386     } else {
 387         return join_value(',', $value);
 388     }
 389 }
 390
 391 # initialize stack: command line definitions
 392 unshift @stack, {};
 393
 394 # Get command line stuff
 395 if ($has_getopt) {
 396     my ($opt_noexec, $opt_flush, $opt_lines, $opt_interactive,
 397         $opt_verbose, $opt_debug,
 398         $opt_help,
 399         $opt_version, $opt_test, $opt_fast, $opt_shell,
 400         $opt_domain);
 401
 402     Getopt::Long::Configure('bundling', 'auto_help', 'no_ignore_case',
 403                             'no_auto_abbrev');
 404
 405     sub opt_def {
 406         my ($opt, $value) = @_;
 407         die 'Invalid --def specification'
 408           unless $value =~ /^\$?(\w+)=(.*)$/s;
 409         my ($name, $unparsed_value) = ($1, $2);
 410         my @tokens = tokenize_string($unparsed_value);
 411         my $value = getvalues(\&next_array_token, \@tokens);
 412         die 'Extra tokens after --def'
 413           if @tokens;
 414         $stack[0]{vars}{$name} = $value;
 415     }
 416
 417     local $SIG{__WARN__} = sub { die $_[0]; };
 418     GetOptions('noexec|n' => \$opt_noexec,
 419                'flush|F' => \$opt_flush,
 420                'lines|l' => \$opt_lines,
 421                'interactive|i' => \$opt_interactive,
 422                'verbose|v' => \$opt_verbose,
 423                'debug|d' => \$opt_debug,
 424                'help|h' => \$opt_help,
 425                'version|V' => \$opt_version,
 426                test => \$opt_test,
 427                remote => \$opt_test,
 428                fast => \$opt_fast,
 429                shell => \$opt_shell,
 430                'domain=s' => \$opt_domain,
 431                'def=s' => \&opt_def,
 432               );
 433
 434     if (defined $opt_help) {
 435         require Pod::Usage;
 436         Pod::Usage::pod2usage(-exitstatus => 0);
 437     }
 438
 439     if (defined $opt_version) {
 440         printversion();
 441         exit 0;
 442     };
 443
 444     $option{'noexec'} = (defined $opt_noexec);
 445     $option{flush} = defined $opt_flush;
 446     $option{'lines'} = (defined $opt_lines);
 447     $option{interactive} = (defined $opt_interactive);
 448     $option{test} = (defined $opt_test);
 449
 450     if ($option{test}) {
 451         $option{noexec} = 1;
 452         $option{lines} = 1;
 453     }
 454
 455     delete $option{interactive} if $option{noexec};
 456
 457     mydie('ferm interactive mode not possible: /dev/stdin is not a tty')
 458       if $option{interactive} and not -t STDIN;
 459     mydie('ferm interactive mode not possible: /dev/stderr is not a tty')
 460       if $option{interactive} and not -t STDERR;
 461
 462     $option{fast} = 1 if defined $opt_fast;
 463
 464     if (defined $opt_shell) {
 465         $option{$_} = 1 foreach qw(shell fast lines);
 466     }
 467
 468     $option{domain} = $opt_domain if defined $opt_domain;
 469
 470     print STDERR "Warning: ignoring the obsolete --debug option\n"
 471       if defined $opt_debug;
 472     print STDERR "Warning: ignoring the obsolete --verbose option\n"
 473       if defined $opt_verbose;
 474 } else {
 475     # tiny getopt emulation for microperl
 476     my $filename;
 477     foreach (@ARGV) {
 478         if ($_ eq '--noexec' or $_ eq '-n') {
 479             $option{noexec} = 1;
 480         } elsif ($_ eq '--lines' or $_ eq '-l') {
 481             $option{lines} = 1;
 482         } elsif ($_ eq '--fast') {
 483             $option{fast} = 1;
 484         } elsif ($_ eq '--test') {
 485             $option{noexec} = 1;
 486             $option{lines} = 1;
 487         } elsif ($_ eq '--shell') {
 488             $option{$_} = 1 foreach qw(shell fast lines);
 489         } elsif (/^-/) {
 490             printf STDERR "Usage: ferm [--noexec] [--lines] [--fast] [--shell] FILENAME\n";
 491             exit 1;
 492         } else {
 493             $filename = $_;
 494         }
 495     }
 496     undef @ARGV;
 497     push @ARGV, $filename;
 498 }
 499
 500 unless (@ARGV == 1) {
 501     require Pod::Usage;
 502     Pod::Usage::pod2usage(-exitstatus => 1);
 503 }
 504
 505 if ($has_strict) {
 506     open LINES, ">&STDOUT" if $option{lines};
 507     open STDOUT, ">&STDERR" if $option{shell};
 508 } else {
 509     # microperl can't redirect file handles
 510     *LINES = *STDOUT;
 511
 512     if ($option{fast} and not $option{noexec}) {
 513         print STDERR "Sorry, ferm on microperl does not allow --fast without --noexec\n";
 514         exit 1
 515     }
 516 }
 517
 518 unshift @stack, {};
 519 open_script($ARGV[0]);
 520
 521 # parse all input recursively
 522 enter(0);
 523 die unless @stack == 2;
 524
 525 # check consistency
 526 check();
 527
 528 # execute all generated rules
 529 my $status;
 530
 531 foreach my $cmd (@pre_hooks) {
 532     print LINES "$cmd\n" if $option{lines};
 533     system($cmd) unless $option{noexec};
 534 }
 535
 536 while (my ($domain, $rules) = each %rules) {
 537     my $s = $option{fast} &&
 538       defined $domains{$domain}{tools}{'tables-restore'}
 539       ? execute_fast($domain, rules_to_save($domain, $rules))
 540         : execute_slow($domain, $rules);
 541     $status = $s if defined $s;
 542 }
 543
 544 foreach my $cmd (@post_hooks) {
 545     print "$cmd\n" if $option{lines};
 546     system($cmd) unless $option{noexec};
 547 }
 548
 549 if (defined $status) {
 550     rollback();
 551     exit $status;
 552 }
 553
 554 # ask user, and rollback if there is no confirmation
 555
 556 confirm_rules() or rollback() if $option{interactive};
 557
 558 exit 0;
 559
 560 # end of program execution!
 561
 562
 563 # funcs
 564
 565 sub printversion {
 566     print "ferm $VERSION\n";
 567     print "Copyright (C) 2001-2007 Auke Kok, Max Kellermann\n";
 568     print "This program is free software released under GPLv2.\n";
 569     print "See the included COPYING file for license details.\n";
 570 }
 571
 572
 573 sub mydie {
 574     print STDERR @_;
 575     print STDERR "\n";
 576     exit 1;
 577 }
 578
 579
 580 sub error {
 581     # returns a nice formatted error message, showing the
 582     # location of the error.
 583     my $tabs = 0;
 584     my @lines;
 585     my $l = 0;
 586     my @words = @{$script->{past_tokens}};
 587
 588     for my $w ( 0 .. $#words ) {
 589         if ($words[$w] eq "\x29")
 590             { $l++ ; $lines[$l] = "    " x ($tabs-- -1) ;};
 591         if ($words[$w] eq "\x28")
 592             { $l++ ; $lines[$l] = "    " x $tabs++ ;};
 593         if ($words[$w] eq "\x7d")
 594             { $l++ ; $lines[$l] = "    " x ($tabs-- -1) ;};
 595         if ($words[$w] eq "\x7b")
 596             { $l++ ; $lines[$l] = "    " x $tabs++ ;};
 597         if ( $l > $#lines ) { $lines[$l] = "" };
 598         $lines[$l] .= $words[$w] . " ";
 599         if ($words[$w] eq "\x28")
 600             { $l++ ; $lines[$l] = "    " x $tabs ;};
 601         if (($words[$w] eq "\x29") && ($words[$w+1] ne "\x7b"))
 602             { $l++ ; $lines[$l] = "    " x $tabs ;};
 603         if ($words[$w] eq "\x7b")
 604             { $l++ ; $lines[$l] = "    " x $tabs ;};
 605         if (($words[$w] eq "\x7d") && ($words[$w+1] ne "\x7d"))
 606             { $l++ ; $lines[$l] = "    " x $tabs ;};
 607         if (($words[$w] eq "\x3b") && ($words[$w+1] ne "\x7d"))
 608             { $l++ ; $lines[$l] = "    " x $tabs ;}
 609         if ($words[$w-1] eq "option")
 610             { $l++ ; $lines[$l] = "    " x $tabs ;}
 611     }
 612     my $start = $#lines - 4;
 613     if ($start < 0) { $start = 0 } ;
 614     print STDERR "Error in $script->{filename} line $script->{line}:\n";
 615     for $l ( $start .. $#lines)
 616         { print STDERR $lines[$l]; if ($l != $#lines ) {print STDERR "\n"} ; };
 617     print STDERR "<--\n";
 618     mydie(@_);
 619 }
 620
 621 # print a warning message about code from an input file
 622 sub warning {
 623     print STDERR "Warning in $script->{filename} line $script->{line}: "
 624       . (shift) . "\n";
 625 }
 626
 627 sub find_tool($) {
 628     my $name = shift;
 629     return $name if $option{test};
 630     for my $path ('/sbin', split ':', $ENV{PATH}) {
 631         my $ret = "$path/$name";
 632         return $ret if -x $ret;
 633     }
 634     die "$name not found in PATH\n";
 635 }
 636
 637 sub initialize_domain {
 638     my $domain = shift;
 639
 640     return if exists $domains{$domain}{initialized};
 641
 642     die "Invalid domain '$domain'\n" unless $domain =~ /^(?:ip6?|arp|eb)$/;
 643
 644     my @tools = qw(tables);
 645     push @tools, qw(tables-save tables-restore)
 646       if $domain =~ /^ip6?$/;
 647
 648     # determine the location of this domain's tools
 649     foreach my $tool (@tools) {
 650         $domains{$domain}{tools}{$tool} = find_tool("${domain}${tool}");
 651     }
 652
 653     # make tables-save tell us about the state of this domain
 654     # (which tables and chains do exist?), also remember the old
 655     # save data which may be used later by the rollback function
 656     local *SAVE;
 657     if (!$option{test} &&
 658         exists $domains{$domain}{tools}{'tables-save'} &&
 659         open(SAVE, "$domains{$domain}{tools}{'tables-save'}|")) {
 660         my $save = '';
 661
 662         my $table_info;
 663         while (<SAVE>) {
 664             $save .= $_;
 665
 666             if (/^\*(\w+)/) {
 667                 my $table = $1;
 668                 $table_info = $domains{$domain}{tables}{$table} ||= {};
 669             } elsif (defined $table_info and /^:(\w+)\s+(\S+)/
 670                      and $2 ne '-') {
 671                 $table_info->{chains}{$1}{builtin} = 1;
 672                 $table_info->{has_builtin} = 1;
 673             }
 674         }
 675
 676         # for rollback
 677         $domains{$domain}{previous} = $save;
 678     }
 679
 680     $domains{$domain}{initialized} = 1;
 681 }
 682
 683 # split the an input string into words and delete comments
 684 sub tokenize_string($) {
 685     my $string = shift;
 686
 687     my @ret;
 688
 689     foreach my $word ($string =~ m/(".*?"|'.*?'|`.*?`|[!,=&\$\%\(\){};]|[-+\w\/\.:]+|@\w+|#)/g) {
 690         last if $word eq '#';
 691         push @ret, $word;
 692     }
 693
 694     return @ret;
 695 }
 696
 697 # shift an array; helper function to be passed to &getvar / &getvalues
 698 sub next_array_token {
 699     my $array = shift;
 700     shift @$array;
 701 }
 702
 703 # read some more tokens from the input file into a buffer
 704 sub prepare_tokens() {
 705     return
 706       unless defined $script;
 707
 708     my $tokens = $script->{tokens};
 709     die unless ref $tokens eq 'ARRAY';
 710
 711     while (@$tokens == 0) {
 712         my $handle = $script->{handle};
 713         my $line = <$handle>;
 714         return unless defined $line;
 715
 716         $script->{line} ++;
 717
 718         my @line = tokenize_string($line);
 719
 720         # the next parser stage eats this
 721         push @$tokens, @line;
 722     }
 723
 724     return 1;
 725 }
 726
 727 # open a ferm sub script
 728 sub open_script($) {
 729     my $filename = shift;
 730
 731     for (my $s = $script; defined $s; $s = $s->{parent}) {
 732         mydie("Circular reference in $script->{filename} line $script->{line}: $filename")
 733           if $s->{filename} eq $filename;
 734     }
 735
 736     local *FILE;
 737     open FILE, "<$filename"
 738       or mydie("Failed to open $filename: $!");
 739     my $handle = *FILE;
 740
 741     $script = { filename => $filename,
 742                 handle => $handle,
 743                 line => 0,
 744                 past_tokens => [],
 745                 tokens => [],
 746                 parent => $script,
 747               };
 748
 749     return $script;
 750 }
 751
 752 # collect script filenames which are being included
 753 sub collect_filenames(@) {
 754     my @ret;
 755
 756     # determine the current script's parent directory for relative
 757     # file names
 758     die unless defined $script;
 759     my $parent_dir = $script->{filename} =~ m,^(.*/),
 760       ? $1 : './';
 761
 762     foreach my $pathname (@_) {
 763         # non-absolute file names are relative to the parent script's
 764         # file name
 765         $pathname = $parent_dir . $pathname
 766           unless $pathname =~ m,^/,;
 767
 768         if ($pathname =~ m,/$,) {
 769             # include all regular files in a directory
 770
 771             error("'$pathname' is not a directory")
 772               unless -d $pathname;
 773
 774             local *DIR;
 775             opendir DIR, $pathname
 776               or error("Failed to open directory '$pathname': $!");
 777             my @names = readdir DIR;
 778             closedir DIR;
 779
 780             # sort those names for a well-defined order
 781             foreach my $name (sort { $a cmp $b } @names) {
 782                 # don't include hidden and backup files
 783                 next if /^\.|~$/;
 784
 785                 my $filename = $pathname . $name;
 786                 push @ret, $filename
 787                   if -f $filename;
 788             }
 789         } elsif ($pathname =~ m,\|$,) {
 790             # run a program and use its output
 791             push @ret, $pathname;
 792         } elsif ($pathname =~ m,^\|,) {
 793             error('This kind of pipe is not allowed');
 794         } else {
 795             # include a regular file
 796
 797             error("'$pathname' is a directory; maybe use trailing '/' to include a directory?")
 798               if -d $pathname;
 799             error("'$pathname' is not a file")
 800               unless -f $pathname;
 801
 802             push @ret, $pathname;
 803         }
 804     }
 805
 806     return @ret;
 807 }
 808
 809 # peek a token from the queue, but don't remove it
 810 sub peek_token() {
 811     # get a token
 812     prepare_tokens();
 813
 814     return
 815       unless defined $script;
 816
 817     my $tokens = $script->{tokens};
 818     die unless ref $tokens eq 'ARRAY';
 819
 820     return
 821       unless @$tokens;
 822
 823     return $tokens->[0];
 824 }
 825
 826 # get a token from the queue
 827 sub next_token() {
 828     prepare_tokens();
 829
 830     return
 831       unless defined $script;
 832
 833     my $tokens = $script->{tokens};
 834     die unless ref $tokens eq 'ARRAY';
 835
 836     return
 837       unless @$tokens;
 838
 839     my $token = shift @$tokens;
 840
 841     # update $script->{past_tokens}
 842     my $past_tokens = $script->{past_tokens};
 843     die unless ref $past_tokens eq 'ARRAY';
 844
 845     if (@$past_tokens and
 846         ($past_tokens->[@$past_tokens - 1] eq '}' or
 847          $past_tokens->[@$past_tokens - 1] eq ';')) {
 848         # now this is tricky: $script->{past_tokens} is used in error
 849         # messages. in the following lines, we filter out everything
 850         # which has become irrelevant for error messages,
 851         # i.e. previous (completed) commands
 852
 853         my $t = pop @$past_tokens;
 854
 855         # track the current level - a '}' means one level up (we are
 856         # going backwards)
 857         my $level = $t eq '}' ? 1 : 0;
 858
 859         while (@$past_tokens and $level >= 0) {
 860             $t = pop @$past_tokens;
 861
 862             if ($level == 0 and ($t eq '}' or $t eq ';')) {
 863                 # don't delete another command
 864                 push @$past_tokens, $t;
 865                 last;
 866             } elsif ($t eq '}') {
 867                 # one level up
 868                 $level++;
 869             } elsif ($t eq '{') {
 870                 # one level down. stop here if we're already at level
 871                 # zero
 872                 if ($level == 0) {
 873                     push @$past_tokens, $t;
 874                     last;
 875                 }
 876
 877                 $level--;
 878             }
 879         }
 880     }
 881
 882     push @$past_tokens, $token;
 883
 884     # return
 885     return $token;
 886 }
 887
 888 # require that another token exists, and that it's not a "special"
 889 # token, e.g. ";" and "{"
 890 sub require_next_token {
 891     my $code = shift || \&next_token;
 892
 893     my $token = &$code(@_);
 894
 895     error('unexpected end of file')
 896       unless defined $token;
 897
 898     error("'$token' not allowed here")
 899       if $token =~ /^[;{}]$/;
 900
 901     return $token;
 902 }
 903
 904 # return the value of a variable
 905 sub variable_value($) {
 906     my $name = shift;
 907
 908     foreach (@stack) {
 909         return $_->{vars}{$name}
 910           if exists $_->{vars}{$name};
 911     }
 912
 913     return $stack[0]{auto}{$name}
 914       if exists $stack[0]{auto}{$name};
 915
 916     return;
 917 }
 918
 919 # determine the value of a variable, die if the value is an array
 920 sub string_variable_value($) {
 921     my $name = shift;
 922     my $value = variable_value($name);
 923
 924     error("variable '$name' must be a string, is an array")
 925       if ref $value;
 926
 927     return $value;
 928 }
 929
 930 # similar to the built-in "join" function, but also handle negated
 931 # values in a special way
 932 sub join_value($$) {
 933     my ($expr, $value) = @_;
 934
 935     unless (ref $value) {
 936         return $value;
 937     } elsif (ref $value eq 'ARRAY') {
 938         return join($expr, @$value);
 939     } elsif (ref $value eq 'negated') {
 940         # bless'negated' is a special marker for negated values
 941         $value = join_value($expr, $value->[0]);
 942         return bless [ $value ], 'negated';
 943     } else {
 944         die;
 945     }
 946 }
 947
 948 # returns the next parameter, which may either be a scalar or an array
 949 sub getvalues {
 950     my ($code, $param) = (shift, shift);
 951     my %options = @_;
 952
 953     my $token = require_next_token($code, $param);
 954
 955     if ($token eq '(') {
 956         # read an array until ")"
 957         my @wordlist;
 958
 959         for (;;) {
 960             $token = getvalues($code, $param,
 961                                parenthesis_allowed => 1,
 962                                comma_allowed => 1);
 963
 964             unless (ref $token) {
 965                 last if $token eq ')';
 966
 967                 if ($token eq ',') {
 968                     error('Comma is not allowed within arrays, please use only a space');
 969                     next;
 970                 }
 971
 972                 push @wordlist, $token;
 973             } elsif (ref $token eq 'ARRAY') {
 974                 push @wordlist, @$token;
 975             } else {
 976                 error('unknown toke type');
 977             }
 978         }
 979
 980         error('empty array not allowed here')
 981           unless @wordlist or not $options{non_empty};
 982
 983         return @wordlist == 1
 984           ? $wordlist[0]
 985             : \@wordlist;
 986     } elsif ($token =~ /^\`(.*)\`$/s) {
 987         # execute a shell command, insert output
 988         my $command = $1;
 989         my $output = `$command`;
 990         unless ($? == 0) {
 991             if ($? == -1) {
 992                 error("failed to execute: $!");
 993             } elsif ($? & 0x7f) {
 994                 error("child died with signal " . ($? & 0x7f));
 995             } elsif ($? >> 8) {
 996                 error("child exited with status " . ($? >> 8));
 997             }
 998         }
 999
1000         # remove comments
1001         $output =~ s/#.*//mg;
1002
1003         # tokenize
1004         my @tokens = grep { length } split /\s+/s, $output;
1005
1006         my @values;
1007         while (@tokens) {
1008             my $value = getvalues(\&next_array_token, \@tokens);
1009             push @values, to_array($value);
1010         }
1011
1012         # and recurse
1013         return @values == 1
1014           ? $values[0]
1015             : \@values;
1016     } elsif ($token =~ /^\'(.*)\'$/s) {
1017         # single quotes: a string
1018         return $1;
1019     } elsif ($token =~ /^\"(.*)\"$/s) {
1020         # double quotes: a string with escapes
1021         $token = $1;
1022         $token =~ s,\$(\w+),string_variable_value($1),eg;
1023         return $token;
1024     } elsif ($token eq '!') {
1025         error('negation is not allowed here')
1026           unless $options{allow_negation};
1027
1028         $token = getvalues($code, $param);
1029
1030         error('it is not possible to negate an array')
1031           if ref $token and not $options{allow_array_negation};
1032
1033         return bless [ $token ], 'negated';
1034     } elsif ($token eq ',') {
1035         return $token
1036           if $options{comma_allowed};
1037
1038         error('comma is not allowed here');
1039     } elsif ($token eq '=') {
1040         error('equals operator ("=") is not allowed here');
1041     } elsif ($token eq '$') {
1042         my $name = require_next_token($code, $param);
1043         error('variable name expected - if you want to concatenate strings, try using double quotes')
1044           unless $name =~ /^\w+$/;
1045
1046         my $value = variable_value($name);
1047
1048         error("no such variable: \$$name")
1049           unless defined $value;
1050
1051         return $value;
1052     } elsif ($token eq '&') {
1053         error("function calls are not allowed as keyword parameter");
1054     } elsif ($token eq ')' and not $options{parenthesis_allowed}) {
1055         error('Syntax error');
1056     } elsif ($token =~ /^@/) {
1057         if ($token eq '@resolve') {
1058             my @params = get_function_params();
1059             error('Usage: @resolve((hostname ...))')
1060               unless @params == 1;
1061             eval { require Net::DNS; };
1062             error('For the @resolve() function, you need the Perl library Net::DNS')
1063               if $@;
1064             my $type = 'A';
1065             my $resolver = new Net::DNS::Resolver;
1066             my @result;
1067             foreach my $hostname (to_array($params[0])) {
1068                 my $query = $resolver->search($hostname, $type);
1069                 error("DNS query for '$hostname' failed: " . $resolver->errorstring)
1070                   unless $query;
1071                 foreach my $rr ($query->answer) {
1072                     next unless $rr->type eq $type;
1073                     push @result, $rr->address;
1074                 }
1075             }
1076             return \@result;
1077         } else {
1078             error("unknown ferm built-in function");
1079         }
1080     } else {
1081         return $token;
1082     }
1083 }
1084
1085 # returns the next parameter, but only allow a scalar
1086 sub getvar {
1087     my $token = getvalues(@_);
1088
1089     error('array not allowed here')
1090       if ref $token and ref $token eq 'ARRAY';
1091
1092     return $token;
1093 }
1094
1095 sub get_function_params(%) {
1096     my $token = next_token();
1097     error('function name must be followed by "()"')
1098       unless defined $token and $token eq '(';
1099
1100     $token = peek_token();
1101     if ($token eq ')') {
1102         require_next_token;
1103         return;
1104     }
1105
1106     my @params;
1107
1108     while (1) {
1109         if (@params > 0) {
1110             $token = require_next_token();
1111             last
1112               if $token eq ')';
1113
1114             error('"," expected')
1115               unless $token eq ',';
1116         }
1117
1118         push @params, getvalues(undef, undef, @_);
1119     }
1120
1121     return @params;
1122 }
1123
1124 # collect all tokens in a flat array reference until the end of the
1125 # command is reached
1126 sub collect_tokens() {
1127     my @level;
1128     my @tokens;
1129
1130     while (1) {
1131         my $keyword = next_token();
1132         error('unexpected end of file within function/variable declaration')
1133           unless defined $keyword;
1134
1135         if ($keyword =~ /^[\{\(]$/) {
1136             push @level, $keyword;
1137         } elsif ($keyword =~ /^[\}\)]$/) {
1138             my $expected = $keyword;
1139             $expected =~ tr/\}\)/\{\(/;
1140             my $opener = pop @level;
1141             error("unmatched '$keyword'")
1142               unless defined $opener and $opener eq $expected;
1143         } elsif ($keyword eq ';' and @level == 0) {
1144             last;
1145         }
1146
1147         push @tokens, $keyword;
1148
1149         last
1150           if $keyword eq '}' and @level == 0;
1151     }
1152
1153     return \@tokens;
1154 }
1155
1156
1157 # returns the specified value as an array. dereference arrayrefs
1158 sub to_array($) {
1159     my $value = shift;
1160     die unless wantarray;
1161     die if @_;
1162     unless (ref $value) {
1163         return $value;
1164     } elsif (ref $value eq 'ARRAY') {
1165         return @$value;
1166     } else {
1167         die;
1168     }
1169 }
1170
1171 # evaluate the specified value as bool
1172 sub eval_bool($) {
1173     my $value = shift;
1174     die if wantarray;
1175     die if @_;
1176     unless (ref $value) {
1177         return $value;
1178     } elsif (ref $value eq 'ARRAY') {
1179         return @$value > 0;
1180     } else {
1181         die;
1182     }
1183 }
1184
1185 sub is_netfilter_core_target($) {
1186     my $target = shift;
1187     die unless defined $target and length $target;
1188
1189     return $target =~ /^(?:ACCEPT|DROP|RETURN|QUEUE)$/;
1190 }
1191
1192 sub is_netfilter_module_target($$) {
1193     my ($domain_family, $target) = @_;
1194     die unless defined $target and length $target;
1195
1196     return defined $domain_family &&
1197       exists $target_defs{$domain_family} &&
1198         exists $target_defs{$domain_family}{$target};
1199 }
1200
1201 sub is_netfilter_builtin_chain($$) {
1202     my ($table, $chain) = @_;
1203
1204     return grep { $_ eq $chain }
1205       qw(PREROUTING INPUT FORWARD OUTPUT POSTROUTING);
1206 }
1207
1208 # escape the string in a way safe for the shell
1209 sub shell_escape($) {
1210     my $token = shift;
1211
1212     if ($option{fast}) {
1213         # iptables-save/iptables-restore are quite buggy concerning
1214         # escaping and special characters... we're trying our best
1215         # here
1216
1217         $token =~ s,",',g;
1218         $token = '"' . $token . '"'
1219           if $token =~ /[\s\'\\;]/s;
1220     } else {
1221         return $token
1222           if $token =~ /^\`.*\`$/;
1223         $token =~ s/'/\\'/g;
1224         $token = '\'' . $token . '\''
1225           if $token =~ /[\s\"\\;<>|]/s;
1226     }
1227
1228     return $token;
1229 }
1230
1231 # append parameters to a shell command line, with the correct escape
1232 # sequences
1233 sub shell_append($@) {
1234     my $ref = shift;
1235
1236     foreach (@_) {
1237         $$ref .= ' ' . shell_escape($_);
1238     }
1239 }
1240
1241 # append an option to the shell command line, using information from
1242 # the module definition (see %match_defs etc.)
1243 sub shell_append_option($$$$) {
1244     my ($ref, $def, $keyword, $value) = @_;
1245
1246     my @negated;
1247     if (ref $value and ref $value eq 'negated') {
1248         $value = $value->[0];
1249
1250         if (exists $def->{pre_negation}) {
1251             shell_append($ref, '!');
1252         } else {
1253             push @negated, '!';
1254         }
1255     }
1256
1257     unless (defined $value) {
1258         shell_append($ref, "--$keyword");
1259     } elsif (ref $value and ref $value eq 'params') {
1260         shell_append($ref, "--$keyword", @negated, @$value);
1261     } elsif (ref $value and ref $value eq 'ARRAY') {
1262         foreach (@$value) {
1263             shell_append($ref, "--$keyword", $_);
1264         }
1265     } else {
1266         shell_append($ref, "--$keyword", @negated, $value);
1267     }
1268 }
1269
1270 # dereference a bless'negated'
1271 sub extract_negation($) {
1272     local $_ = shift;
1273     ref && ref eq 'negated'
1274       ? ( '!', $_->[0] )
1275         : $_;
1276 }
1277
1278 # reset a netfilter domain: set all policies to ACCEPT, clear all
1279 # rules, delete custom chains
1280 sub reset_domain($) {
1281     my $domain = shift;
1282     my $domain_info = $domains{$domain};
1283
1284     my $path = $domain_info->{tools}{tables};
1285
1286     my @rules;
1287     while (my ($table, $table_info) = each %{$domain_info->{tables}}) {
1288         while (my ($chain, $chain_info) = each %{$table_info->{chains}}) {
1289             next unless $chain_info->{builtin} or
1290               (not $table_info->{has_builtin} and
1291                is_netfilter_builtin_chain($table, $chain));
1292             push @rules, "$path -t $table -P $chain ACCEPT\n";
1293         }
1294
1295         push @rules,
1296           "$path -t $table -F\n", "$path -t $table -X\n";
1297     }
1298
1299     return @rules;
1300 }
1301
1302 # convert an internal rule structure into an iptables call
1303 sub tables($) {
1304     my $rule = shift;
1305     my %rule = %$rule;
1306
1307     my $domain = $rule{domain};
1308     my $domain_info = $domains{$domain};
1309     my $domain_family = $rule{domain_family};
1310
1311     my $table = $rule{table};
1312     my $table_info = $domain_info->{tables}{$table} ||= {};
1313
1314     my $rules = $rules{$domain} ||= [];
1315
1316     my $chain = $rule{chain};
1317     my $chain_info = $table_info->{chains}{$chain} ||= {};
1318
1319     return if $option{flush};
1320
1321     my $action = $rule{action};
1322
1323     my $rr = shell_escape($domain_info->{tools}{tables});
1324     shell_append(\$rr, '-t', $table);
1325
1326     # should we set a policy?
1327     if (exists $chain_info->{set_policy}) {
1328         my $policy = $chain_info->{policy};
1329
1330         push @$rules, "$rr -P $chain $policy\n";
1331
1332         delete $chain_info->{set_policy};
1333     }
1334
1335     # mark this chain as "non-empty" because we will add stuff to
1336     # it now; this flag is later used to check if a custom chain
1337     # referenced by "jump" was actually defined
1338     $chain_info->{non_empty} = 1;
1339
1340     # check if the chain is already defined
1341     unless (exists $chain_info->{was_created} or
1342             is_netfilter_builtin_chain($table, $chain)) {
1343         push @$rules, "$rr -N $chain\n";
1344         $chain_info->{was_created} = 1;
1345     }
1346
1347     # check for unknown jump target
1348     if (defined $action and
1349         ($action->{type} eq 'jump' or
1350          $action->{type} eq 'goto') and
1351         not exists $table_info->{chains}{$action->{chain}}{was_created}) {
1352         my $chain = $action->{chain};
1353         push @$rules, "$rr -N $chain\n";
1354         $table_info->{chains}{$chain}{was_created} = 1;
1355     }
1356
1357     # return if this is a policy-only rule
1358     return
1359       unless $rule{has_rule};
1360
1361     shell_append(\$rr, '-A', $chain);
1362
1363     # modules; copy the hash because we might add automatic protocol
1364     # modules later
1365     my %modules;
1366     if (exists $rule{modules}) {
1367         %modules = %{$rule{modules}};
1368         shell_append(\$rr, '-m', $_)
1369           foreach keys %modules;
1370     }
1371
1372     # general iptables options
1373
1374     if (exists $match_defs{$domain_family} and
1375         exists $match_defs{$domain_family}{''}) {
1376         while (my ($keyword, $k) = each %{$match_defs{$domain_family}{''}{keywords}}) {
1377             my $key = "builtin____${keyword}";
1378             next unless exists $rule{$key};
1379             my $value = $rule->{$key};
1380
1381             shell_append_option(\$rr, $k, $keyword, $value);
1382         }
1383     }
1384
1385     #
1386     # match module options
1387     #
1388
1389     if (defined $rule{builtin____protocol}) {
1390         my $proto = $rule{builtin____protocol};
1391         $proto = 'icmpv6'
1392           if $domain eq 'ip6' and $proto eq 'ipv6-icmp';
1393         $proto = 'mh'
1394           if $domain eq 'ip6' and $proto eq 'ipv6-mh';
1395
1396         if (exists $proto_defs{$domain_family}{$proto}) {
1397             my $def = $proto_defs{$domain_family}{$proto};
1398             while (my ($keyword, $k) = each %{$def->{keywords}}) {
1399                 my $key = "protocol__${proto}__$keyword";
1400                 next unless exists $rule{$key};
1401                 my $value = $rule->{$key};
1402
1403                 my $module = $proto eq 'icmpv6' ? 'icmp6' : $proto;
1404                 unless (exists $modules{$module}) {
1405                     shell_append(\$rr, '-m', $module);
1406                     $modules{$module} = 1;
1407                 }
1408
1409                 shell_append_option(\$rr, $k, $keyword, $value);
1410             }
1411         }
1412
1413         # special case: --dport and --sport for TCP/UDP
1414         if ($domain_family eq 'ip' and
1415             (exists $rule{dport} or exists $rule{sport}) and
1416             $proto =~ /^(?:tcp|udp|udplite|dccp|sctp)$/) {
1417             unless (exists $modules{$proto}) {
1418                 shell_append(\$rr, '-m', $proto);
1419                 $modules{$proto} = 1;
1420             }
1421
1422             shell_append_option(\$rr, { params => 1,
1423                                         negation => 1,
1424                                       }, 'dport', $rule{dport})
1425               if exists $rule{dport};
1426             shell_append_option(\$rr, { params => 1,
1427                                         negation => 1,
1428                                       }, 'sport', $rule{sport})
1429               if exists $rule{sport};
1430         }
1431     }
1432
1433     # modules stored in %match_defs
1434     while (my ($key, $value) = each %rule) {
1435         next unless $key =~ /^module__(\w+)__([-\w]+)$/;
1436         my ($module_name, $keyword) = ($1, $2);
1437
1438         my $def = $match_defs{$rule{domain_family}}{$module_name}{keywords}{$keyword};
1439         die unless defined $def;
1440
1441         shell_append_option(\$rr, $def, $keyword, $value);
1442     }
1443
1444     #
1445     # target options
1446     #
1447
1448     if ($action->{type} eq 'jump') {
1449         shell_append(\$rr, '-j', $action->{chain});
1450     } elsif ($action->{type} eq 'goto') {
1451         shell_append(\$rr, '-g', $action->{chain});
1452     } elsif ($action->{type} eq 'target') {
1453         shell_append(\$rr, '-j', $action->{target});
1454
1455         # targets stored in %target_defs
1456
1457         while (my ($keyword, $value) = each %{$rule{target_options}}) {
1458             my $def = $target_defs{$domain_family}{$action->{target}}{keywords}{$keyword};
1459             die unless defined $def;
1460
1461             shell_append_option(\$rr, $def, $keyword, $value);
1462         }
1463     } elsif ($action->{type} ne 'nop') {
1464         die;
1465     }
1466
1467     # this line is done
1468     $rr .= "\n";
1469     push @$rules, { rule => $rr,
1470                     script => $rule{script},
1471                   };
1472 };
1473
1474 sub transform_rule($) {
1475     my $rule = shift;
1476
1477     $rule->{builtin____protocol} = 'icmpv6'
1478       if $rule->{domain} eq 'ip6' and $rule->{builtin____protocol} eq 'icmp';
1479 }
1480
1481 sub printrule($) {
1482     my $rule = shift;
1483
1484     transform_rule($rule);
1485
1486     # prints all rules in a hash
1487     tables($rule);
1488 }
1489
1490
1491 # convert a bunch of internal rule structures in iptables calls,
1492 # unfold arrays during that
1493 sub mkrules($) {
1494     # compile the list hashes into rules
1495     my $fw = shift;
1496
1497     # pack the data in a handy format (list-of-hashes with one kw
1498     # per level, so we can recurse...
1499     my @fr;
1500
1501     foreach my $current (@$fw) {
1502         while (my ($key, $value) = each %$current) {
1503             push @fr, [ $key, $value ];
1504         }
1505     }
1506
1507     sub dofr($@) {
1508         my $rule = shift;
1509         my $current = shift;
1510
1511         my ($key, $value_string) = @$current;
1512
1513         unless (ref $value_string and
1514                 $key ne 'target_options' and
1515                 ref $value_string ne 'params' and
1516                 ref $value_string ne 'negated') {
1517                 # set this one and recurse
1518             $rule->{$key} = $value_string;
1519
1520             if (@_) {
1521                 dofr($rule, @_);
1522             } else {
1523                 printrule($rule);
1524             }
1525
1526             delete $rule->{$key};
1527         } elsif (ref $value_string eq 'ARRAY') {
1528             # recurse for every value
1529             foreach my $value (@$value_string) {
1530                 # set this one and recurse
1531                 $rule->{$key} = $value;
1532
1533                 if (@_) {
1534                     dofr($rule, @_);
1535                 } else {
1536                     printrule($rule);
1537                 }
1538             }
1539
1540             delete $rule->{$key};
1541         } elsif (ref $value_string eq 'HASH') {
1542             # merge hashes
1543             my $old = $rule->{$key};
1544
1545             $rule->{$key} = { ( defined $old
1546                                 ? %$old
1547                                 : ()
1548                               ),
1549                               %$value_string
1550                             };
1551
1552             # recurse
1553             if (@_) {
1554                 dofr($rule, @_);
1555             } else {
1556                 printrule($rule);
1557             }
1558
1559             # restore old value
1560             if (defined $old) {
1561                 $rule->{$key} = $old;
1562             } else {
1563                 delete $rule->{$key};
1564             }
1565         } else {
1566             die ref $value_string;
1567         }
1568     }
1569
1570     dofr({}, @fr);
1571 }
1572
1573 # find an option in the rule stack
1574 sub find_option($$) {
1575     my ($fw, $key) = @_;
1576
1577     my $item = (grep { exists $_->{$key} } reverse @$fw)[0];
1578     return unless defined $item;
1579
1580     return $item->{$key};
1581 }
1582
1583 sub filter_domains($) {
1584     my $domains = shift;
1585     my $result = [];
1586
1587     foreach my $domain (to_array $domains) {
1588         next if exists $option{domain}
1589           and $domain ne $option{domain};
1590
1591         eval {
1592             initialize_domain($domain);
1593         };
1594         error($@) if $@;
1595
1596         push @$result, $domain;
1597     }
1598
1599     return @$result == 1 ? $result->[0] : $result;
1600 }
1601
1602 # parse tokens from builtin match modules
1603 sub parse_builtin_matches($$$$$) {
1604     my ($fw, $current, $domain_family, $keyword, $negated_ref) = @_;
1605
1606     if (exists $match_defs{$domain_family}) {
1607         parse_option('builtin', $match_defs{$domain_family}, '',
1608                      $fw, $current,
1609                      $keyword, $negated_ref)
1610           and return 1;
1611     }
1612
1613     return;
1614 }
1615
1616 # parse a keyword from a module definition
1617 sub parse_keyword($$$$) {
1618     my ($fw, $def, $keyword, $negated_ref) = @_;
1619
1620     my $params = $def->{params};
1621
1622     my $value;
1623
1624     my $negated;
1625     if ($$negated_ref && exists $def->{pre_negation}) {
1626         $negated = 1;
1627         undef $$negated_ref;
1628     }
1629
1630     unless (defined $params) {
1631         undef $value;
1632     } elsif (ref $params && ref $params eq 'CODE') {
1633         $value = &$params($fw);
1634     } elsif ($params =~ /^[a-z]/) {
1635         if (exists $def->{negation} and not $negated) {
1636             my $token = peek_token();
1637             if ($token eq '!') {
1638                 require_next_token;
1639                 $negated = 1;
1640             }
1641         }
1642
1643         my @params;
1644         foreach my $p (split(//, $params)) {
1645             if ($p eq 's') {
1646                 push @params, getvar();
1647             } elsif ($p eq 'a') {
1648                 push @params, getvalues();
1649             } elsif ($p eq 'c') {
1650                 my @v = to_array getvalues(undef, undef,
1651                                            non_empty => 1);
1652                 push @params, join(',', @v);
1653             } else {
1654                 die;
1655             }
1656         }
1657
1658         $value = @params == 1
1659           ? $params[0]
1660             : bless \@params, 'params';
1661     } elsif ($params == 1) {
1662         if (exists $def->{negation} and not $negated) {
1663             my $token = peek_token();
1664             if ($token eq '!') {
1665                 require_next_token;
1666                 $negated = 1;
1667             }
1668         }
1669
1670         $value = getvalues();
1671
1672         warning("log-prefix is too long; truncating to 29 characters: '$1'")
1673           if $keyword eq 'log-prefix' && $value =~ s,^(.{29}).+$,$1,;
1674     } else {
1675         if (exists $def->{negation} and not $negated) {
1676             my $token = peek_token();
1677             if ($token eq '!') {
1678                 require_next_token;
1679                 $negated = 1;
1680             }
1681         }
1682
1683         $value = bless [ map {
1684             getvar()
1685         } (1..$params) ], 'params';
1686     }
1687
1688     $value = bless [ $value ], 'negated'
1689       if $negated;
1690
1691     return $value;
1692 }
1693
1694 # parse options of a module
1695 sub parse_option($$$$$$$) {
1696     my ($type, $defs, $name, $fw, $current, $keyword, $negated_ref) = @_;
1697
1698     my $def = $defs->{$name};
1699     return unless defined $def;
1700
1701     my $k = $def->{keywords}{$keyword};
1702     return unless defined $k;
1703
1704     while (exists $k->{alias}) {
1705         die if $k->{alias} eq $keyword;
1706         $keyword = $k->{alias};
1707         $k = $defs->{$name}{keywords}{$keyword};
1708         die unless defined $k;
1709     }
1710
1711     $current->{"${type}__${name}__${keyword}"}
1712       = parse_keyword($fw, $k,
1713                       $keyword, $negated_ref);
1714     return 1;
1715 }
1716
1717 # parse options for a protocol module definition
1718 sub parse_protocol_options($$$$$) {
1719     my ($fw, $current, $proto, $keyword, $negated_ref) = @_;
1720
1721     my $domain_family = find_option($fw, 'domain_family');
1722     my $proto_defs = $proto_defs{$domain_family};
1723     return unless defined $proto_defs;
1724
1725     return parse_option('protocol', $proto_defs, $proto, $fw, $current,
1726                         $keyword, $negated_ref);
1727 }
1728
1729 # parse options of a match module
1730 sub parse_match_option($$$$$$) {
1731     my ($match_defs, $name, $fw, $current, $keyword, $negated_ref) = @_;
1732
1733     return parse_option('module', $match_defs, $name, $fw, $current,
1734                         $keyword, $negated_ref);
1735 }
1736
1737 # parse options for a match module definition
1738 sub parse_module_options($$$$$$) {
1739     my ($fw, $current, $modules, $keyword, $negated_ref, $proto) = @_;
1740
1741     my $domain_family = find_option($fw, 'domain_family');
1742     my $match_defs = $match_defs{$domain_family};
1743     return unless defined $match_defs;
1744
1745     # modules stored in %match_defs
1746     foreach my $name (keys %$modules) {
1747         parse_match_option($match_defs, $name, $fw, $current,
1748                            $keyword, $negated_ref)
1749           and do {
1750               # reset hash
1751               keys %$match_defs;
1752               return 1;
1753           }
1754     }
1755
1756     return;
1757 }
1758
1759 # parse options for a target module definition
1760 sub parse_target_options($$$$) {
1761     my ($fw, $current, $target, $keyword) = @_;
1762
1763     my $domain_family = find_option($fw, 'domain_family');
1764     my $target_defs = $target_defs{$domain_family};
1765     return unless defined $target_defs &&
1766       exists $target_defs->{$target}{keywords}{$keyword};
1767
1768     my $k = $target_defs->{$target}{keywords}{$keyword};
1769
1770     while (exists $k->{alias}) {
1771         die if $k->{alias} eq $keyword;
1772         $keyword = $k->{alias};
1773         $k = $target_defs->{$target}{keywords}{$keyword};
1774         die unless defined $k;
1775     }
1776
1777     my $negated_dummy;
1778     $current->{target_options}{$keyword}
1779       = parse_keyword($fw, $k,
1780                       $keyword, \$negated_dummy);
1781
1782     return 1;
1783 }
1784
1785 # the main parser loop: read tokens, convert them into internal rule
1786 # structures
1787 sub enter($@) {
1788     my $lev = shift;  # current recursion depth
1789     my @fw = @_; # fwset in list of hashes
1790
1791     die unless @fw == $lev;
1792
1793     # enter is the core of the firewall setup, it is a
1794     # simple parser program that recognizes keywords and
1795     # retreives parameters to set up the kernel routing
1796     # chains
1797
1798     my $base_level = $script->{base_level} || 0;
1799     die if $base_level > $lev;
1800
1801     my $current = {};
1802     push @fw, $current;
1803
1804     my $domain_family = find_option(\@fw, 'domain_family');
1805
1806     my %modules = map { $_->{modules} ? %{$_->{modules}} : () } @fw;
1807
1808     # read keywords 1 by 1 and dump into parser
1809     while (defined (my $keyword = next_token())) {
1810         # check if the current rule should be negated
1811         my $negated = $keyword eq '!';
1812         if ($negated) {
1813             # negation. get the next word which contains the 'real'
1814             # rule
1815             $keyword = getvar();
1816
1817             error('unexpected end of file after negation')
1818               unless defined $keyword;
1819         }
1820
1821         # the core: parse all data
1822         SWITCH: for ($keyword)
1823         {
1824             # deprecated keyword?
1825             if (exists $deprecated_keywords{$keyword}) {
1826                 my $new_keyword = $deprecated_keywords{$keyword};
1827                 warning("'$keyword' is deprecated, please use '$new_keyword' instead");
1828                 $keyword = $new_keyword;
1829             }
1830
1831             # effectuation operator
1832             if ($keyword eq ';') {
1833                 my $has_rule = find_option(\@fw, 'has_rule');
1834                 my $action = find_option(\@fw, 'action');
1835                 my $policy = find_option(\@fw, 'policy');
1836                 my $chain = find_option(\@fw, 'chain');
1837
1838                 if ($has_rule and not defined $action) {
1839                     # something is wrong when a rule was specifiedd,
1840                     # but no action
1841                     error('No action defined; did you mean "NOP"?');
1842                 }
1843
1844                 error('No chain defined') unless defined $chain;
1845
1846                 $current->{script} = { filename => $script->{filename},
1847                                        line => $script->{line},
1848                                      };
1849
1850                 mkrules(\@fw)
1851                   if $has_rule or defined $policy;
1852
1853                 # and clean up variables set in this level
1854                 %$current = ();
1855
1856                 next;
1857             }
1858
1859             # conditional expression
1860             if ($keyword eq '@if') {
1861                 unless (eval_bool(getvalues)) {
1862                     collect_tokens;
1863                     my $token = peek_token();
1864                     require_next_token() if $token and $token eq '@else';
1865                 }
1866
1867                 next;
1868             }
1869
1870             if ($keyword eq '@else') {
1871                 # hack: if this "else" has not been eaten by the "if"
1872                 # handler above, we believe it came from an if clause
1873                 # which evaluated "true" - remove the "else" part now.
1874                 collect_tokens;
1875                 next;
1876             }
1877
1878             # hooks for custom shell commands
1879             if ($keyword eq 'hook') {
1880                 error('"hook" must be the first token in a command')
1881                   if keys %$current;
1882
1883                 my $position = getvar();
1884                 my $hooks;
1885                 if ($position eq 'pre') {
1886                     $hooks = \@pre_hooks;
1887                 } elsif ($position eq 'post') {
1888                     $hooks = \@post_hooks;
1889                 } else {
1890                     error("Invalid hook position: '$position'");
1891                 }
1892
1893                 push @$hooks, getvar();
1894
1895                 $keyword = next_token();
1896                 error('";" expected after hook declaration')
1897                   unless defined $keyword and $keyword eq ';';
1898
1899                 next;
1900             }
1901
1902             # recursing operators
1903             if ($keyword eq '{') {
1904                 # push stack
1905                 my $old_stack_depth = @stack;
1906
1907                 unshift @stack, { auto => { %{$stack[0]{auto} || {}} } };
1908
1909                 # recurse
1910                 enter($lev + 1, @fw);
1911
1912                 # pop stack
1913                 shift @stack;
1914                 die unless @stack == $old_stack_depth;
1915
1916                 # after a block, the command is finished, clear this
1917                 # level
1918                 %$current = ();
1919
1920                 next;
1921             }
1922
1923             if ($keyword eq '}') {
1924                 error('Unmatched "}"')
1925                   if $lev <= $base_level;
1926
1927                 # consistency check: check if they havn't forgotten
1928                 # the ';' before the last statement
1929                 error('Missing semicolon before "}"')
1930                   if keys %$current;
1931
1932                 # and exit
1933                 return;
1934             }
1935
1936             # include another file
1937             if ($keyword eq '@include' or $keyword eq 'include') {
1938                 my @files = collect_filenames to_array getvalues;
1939                 $keyword = next_token;
1940                 error('Missing ";" - "include FILENAME" must be the last command in a rule')
1941                   unless defined $keyword and $keyword eq ';';
1942
1943                 foreach my $filename (@files) {
1944                     # save old script, open new script
1945                     my $old_script = $script;
1946                     open_script($filename);
1947                     $script->{base_level} = $lev + 1;
1948
1949                     # push stack
1950                     my $old_stack_depth = @stack;
1951
1952                     my $stack = {};
1953
1954                     if (@stack > 0) {
1955                         # include files may set variables for their parent
1956                         $stack->{vars} = ($stack[0]{vars} ||= {});
1957                         $stack->{functions} = ($stack[0]{functions} ||= {});
1958                         $stack->{auto} = { %{ $stack[0]{auto} || {} } };
1959                     }
1960
1961                     unshift @stack, $stack;
1962
1963                     # parse the script
1964                     enter($lev + 1, @fw);
1965
1966                     # pop stack
1967                     shift @stack;
1968                     die unless @stack == $old_stack_depth;
1969
1970                     # restore old script
1971                     $script = $old_script;
1972                 }
1973
1974                 next;
1975             }
1976
1977             # definition of a variable or function
1978             if ($keyword eq '@def' or $keyword eq 'def') {
1979                 error('"def" must be the first token in a command')
1980                   if keys %$current;
1981
1982                 my $type = require_next_token();
1983                 if ($type eq '$') {
1984                     my $name = require_next_token();
1985                     error('invalid variable name')
1986                       unless $name =~ /^\w+$/;
1987
1988                     $keyword = require_next_token();
1989                     error('"=" expected after variable name')
1990                       unless $keyword eq '=';
1991
1992                     my $value = getvalues(undef, undef, allow_negation => 1);
1993
1994                     $keyword = next_token();
1995                     error('";" expected after variable declaration')
1996                       unless defined $keyword and $keyword eq ';';
1997
1998                     $stack[0]{vars}{$name} = $value
1999                       unless exists $stack[-1]{vars}{$name};
2000                 } elsif ($type eq '&') {
2001                     my $name = require_next_token();
2002                     error('invalid function name')
2003                       unless $name =~ /^\w+$/;
2004
2005                     my @params;
2006                     my $token = next_token();
2007                     error('function parameter list or "()" expected')
2008                       unless defined $token and $token eq '(';
2009                     while (1) {
2010                         $token = require_next_token();
2011                         last if $token eq ')';
2012
2013                         if (@params > 0) {
2014                             error('"," expected')
2015                               unless $token eq ',';
2016
2017                             $token = require_next_token();
2018                         }
2019
2020                         error('"$" and parameter name expected')
2021                           unless $token eq '$';
2022
2023                         $token = require_next_token();
2024                         error('invalid function parameter name')
2025                           unless $token =~ /^\w+$/;
2026
2027                         push @params, $token;
2028                     }
2029
2030                     my %function;
2031
2032                     $function{params} = \@params;
2033
2034                     $keyword = require_next_token;
2035                     error('"=" expected')
2036                       unless $keyword eq '=';
2037
2038                     my $tokens = collect_tokens();
2039                     $function{block} = 1 if grep { $_ eq '{' } @$tokens;
2040                     $function{tokens} = $tokens;
2041
2042                     $stack[0]{functions}{$name} = \%function
2043                       unless exists $stack[-1]{functions}{$name};
2044                 } else {
2045                     error('"$" (variable) or "&" (function) expected');
2046                 }
2047
2048                 next;
2049             }
2050
2051             # def references
2052             if ($keyword eq '$') {
2053                 error('variable references are only allowed as keyword parameter');
2054             }
2055
2056             if ($keyword eq '&') {
2057                 my $name = require_next_token;
2058                 error('function name expected')
2059                   unless $name =~ /^\w+$/;
2060
2061                 my $function;
2062                 foreach (@stack) {
2063                     $function = $_->{functions}{$name};
2064                     last if defined $function;
2065                 }
2066                 error("no such function: \&$name")
2067                   unless defined $function;
2068
2069                 my $paramdef = $function->{params};
2070                 die unless defined $paramdef;
2071
2072                 my @params = get_function_params(allow_negation => 1);
2073
2074                 error("Wrong number of parameters for function '\&$name': "
2075                       . @$paramdef . " expected, " . @params . " given")
2076                   unless @params == @$paramdef;
2077
2078                 my %vars;
2079                 for (my $i = 0; $i < @params; $i++) {
2080                     $vars{$paramdef->[$i]} = $params[$i];
2081                 }
2082
2083                 if ($function->{block}) {
2084                     # block {} always ends the current rule, so if the
2085                     # function contains a block, we have to require
2086                     # the calling rule also ends here
2087                     my $token = next_token();
2088                     error("';' expected after block function call '\&$name'")
2089                       unless defined $token and $token eq ';';
2090                 }
2091
2092                 my @tokens = @{$function->{tokens}};
2093                 for (my $i = 0; $i < @tokens; $i++) {
2094                     if ($tokens[$i] eq '$' and $i + 1 < @tokens and
2095                         exists $vars{$tokens[$i + 1]}) {
2096                         my @value = to_array($vars{$tokens[$i + 1]});
2097                         @value = ('(', @value, ')')
2098                           unless @tokens == 1;
2099                         splice(@tokens, $i, 2, @value);
2100                         $i += @value - 2;
2101                     } elsif ($tokens[$i] =~ m,^"(.*)"$,) {
2102                         $tokens[$i] =~ s,\$(\w+),exists $vars{$1} ? $vars{$1} : "\$$1",eg;
2103                     }
2104                 }
2105
2106                 unshift @{$script->{tokens}}, @tokens;
2107
2108                 next;
2109             }
2110
2111             # where to put the rule?
2112             if ($keyword eq 'domain') {
2113                 error('Domain is already specified')
2114                   if exists $current->{domain};
2115
2116                 my $domain = getvalues();
2117                 my $filtered_domain = filter_domains($domain);
2118                 unless (ref $domain) {
2119                     $domain_family = $domain eq 'ip6' ? 'ip' : $domain;
2120                 } elsif (@$domain == 0) {
2121                     $domain_family = 'none';
2122                 } elsif (grep { not /^ip6?$/s } @$domain) {
2123                     error('Cannot combine non-IP domains');
2124                 } else {
2125                     $domain_family = 'ip';
2126                 }
2127                 $current->{domain_family} = $domain_family;
2128
2129                 $current->{domain} = $stack[0]{auto}{DOMAIN} = $filtered_domain;
2130
2131                 next;
2132             }
2133
2134             if ($keyword eq 'table') {
2135                 error('Table is already specified')
2136                   if exists $current->{table};
2137                 $current->{table} = $stack[0]{auto}{TABLE} = getvalues();
2138
2139                 unless (defined find_option(\@fw, 'domain')) {
2140                     $current->{domain} = filter_domains('ip');
2141                     $current->{domain_family} = $domain_family = 'ip';
2142                 }
2143
2144                 next;
2145             }
2146
2147             if ($keyword eq 'chain') {
2148                 error('Chain is already specified')
2149                   if exists $current->{chain};
2150                 $current->{chain} = $stack[0]{auto}{CHAIN} = getvalues();
2151
2152                 # ferm 1.1 allowed lower case built-in chain names
2153                 foreach (ref $current->{chain} ? @{$current->{chain}} : $current->{chain}) {
2154                     error('Please write built-in chain names in upper case')
2155                       if /^(?:input|forward|output|prerouting|postrouting)$/;
2156                 }
2157
2158                 my $domain = find_option(\@fw, 'domain');
2159                 unless (defined find_option(\@fw, 'domain')) {
2160                     $current->{domain} = filter_domains('ip');
2161                     $current->{domain_family} = $domain_family = 'ip';
2162                 }
2163
2164                 $current->{table} = 'filter'
2165                   unless defined find_option(\@fw, 'table');
2166
2167                 next;
2168             }
2169
2170             # policy for built-in chain
2171             if ($keyword eq 'policy') {
2172                 my $domains = find_option(\@fw, 'domain');
2173                 my $tables = find_option(\@fw, 'table');
2174                 my $chains = find_option(\@fw, 'chain');
2175
2176                 error('Chain must be specified')
2177                   unless defined $chains;
2178
2179                 my $policy = uc getvar();
2180                 error("Invalid policy target: $policy")
2181                   unless $policy =~ /^(?:ACCEPT|DROP)$/;
2182
2183                 foreach my $domain (to_array $domains) {
2184                     foreach my $table (to_array $tables) {
2185                         my $chains_info = $domains{$domain}{tables}{$table}{chains} ||= {};
2186
2187                         foreach my $chain (to_array $chains) {
2188                             error("cannot set the policy for non-builtin chain '$chain'")
2189                               unless is_netfilter_builtin_chain($table, $chain);
2190
2191                             if (exists $chains_info->{$chain}{policy}) {
2192                                 warning('policy for this chain is specified for the second time');
2193                             } else {
2194                                 $chains_info->{$chain}{policy} = $policy;
2195                                 $chains_info->{$chain}{set_policy} = 1;
2196                             }
2197                         }
2198                     }
2199                 }
2200
2201                 $current->{policy} = $policy;
2202                 next;
2203             }
2204
2205             # create a subchain
2206             if ($keyword eq '@subchain' or $keyword eq 'subchain') {
2207                 error('No rule specified before "@subchain"')
2208                   unless find_option(\@fw, 'has_rule');
2209
2210                 my $subchain;
2211                 $keyword = next_token();
2212
2213                 if ($keyword =~ /^(["'])(.*)\1$/s) {
2214                     $subchain = $2;
2215                     $keyword = next_token();
2216                 } else {
2217                     $subchain = 'ferm_auto_' . ++$auto_chain;
2218                 }
2219
2220                 error('"{" or chain name expected after "sub"')
2221                   unless $keyword eq '{';
2222
2223                 # create a deep copy of @fw, only containing values
2224                 # which must be in the subchain
2225                 my @fw2;
2226                 foreach my $fw (@fw) {
2227                     my $fw2 = {};
2228                     foreach my $key (qw(domain domain_family table builtin____protocol)) {
2229                         my $value = $fw->{$key};
2230                         next unless defined $value;
2231                         $value = ref $value
2232                           ? ( ref $value eq 'HASH'
2233                               ? {%$value}
2234                               : [@$value]
2235                             )
2236                             : $value;
2237                         $fw2->{$key} = $value;
2238                     }
2239                     push @fw2, $fw2;
2240                 }
2241
2242                 $fw2[-1]->{chain} = $fw2[-1]->{auto}{CHAIN} = $subchain;
2243
2244                 # enter the block
2245                 enter($lev + 1, @fw2);
2246
2247                 # now handle the parent - it's a jump to the sub chain
2248                 $current->{action} = { type => 'jump',
2249                                        chain => $subchain,
2250                                      };
2251
2252                 $current->{script} = { filename => $script->{filename},
2253                                        line => $script->{line},
2254                                      };
2255
2256                 mkrules(\@fw);
2257
2258                 # and clean up variables set in this level
2259                 %$current = ();
2260
2261                 next;
2262             }
2263
2264             # everything else must be part of a "real" rule, not just
2265             # "policy only"
2266             $current->{has_rule}++;
2267
2268             # extended parameters:
2269             if ($keyword =~ /^mod(?:ule)?$/) {
2270                 my $domains = find_option(\@fw, 'domain');
2271
2272                 foreach my $module (to_array getvalues) {
2273                     $current->{modules}{$module} = 1;
2274                     $modules{$module} = 1;
2275                 }
2276
2277                 next;
2278             }
2279
2280             parse_builtin_matches(\@fw, $current, $domain_family,
2281                                   $keyword, \$negated)
2282               and next;
2283
2284             ###
2285             # actions
2286             #
2287
2288             # jump action
2289             if ($keyword eq 'jump') {
2290                 error('There can only one action per rule')
2291                   if exists $current->{action};
2292                 warning('Please declare the policy in a separate statement')
2293                   if find_option(\@fw, 'policy');
2294                 my $chain = getvar();
2295                 if (is_netfilter_core_target($chain) or
2296                     is_netfilter_module_target($domain_family, $chain)) {
2297                     $current->{action} = { type => 'target',
2298                                            target => $chain,
2299                                          };
2300                 } else {
2301                     $current->{action} = { type => 'jump',
2302                                            chain => $chain,
2303                                          };
2304                 }
2305                 next;
2306             };
2307
2308             # goto action
2309             if ($keyword eq 'realgoto') {
2310                 error('There can only one action per rule')
2311                   if exists $current->{action};
2312                 warning('Please declare the policy in a separate statement')
2313                   if find_option(\@fw, 'policy');
2314                 $current->{action} = { type => 'goto',
2315                                        chain => getvar(),
2316                                      };
2317                 next;
2318             };
2319
2320             # action keywords
2321             if (is_netfilter_core_target($keyword)) {
2322                 error('There can only one action per rule')
2323                   if exists $current->{action};
2324                 warning('Please declare the policy in a separate statement')
2325                   if find_option(\@fw, 'policy');
2326                 $current->{action} = { type => 'target',
2327                                        target => $keyword,
2328                                      };
2329                 next;
2330             }
2331
2332             if ($keyword eq 'NOP') {
2333                 error('There can only one action per rule')
2334                   if exists $current->{action};
2335                 warning('Please declare the policy in a separate statement')
2336                   if find_option(\@fw, 'policy');
2337                 $current->{action} = { type => 'nop',
2338                                      };
2339                 next;
2340             }
2341
2342             if (is_netfilter_module_target($domain_family, $keyword)) {
2343                 error('There can only one action per rule')
2344                   if exists $current->{action};
2345                 warning('Please declare the policy in a separate statement')
2346                   if find_option(\@fw, 'policy');
2347
2348                 if ($keyword eq 'TCPMSS') {
2349                     my $protos = find_option(\@fw, 'builtin____protocol');
2350                     error('No protocol specified before TCPMSS')
2351                       unless defined $protos;
2352                     foreach my $proto (to_array $protos) {
2353                         error('TCPMSS not available for protocol "$proto"')
2354                           unless $proto eq 'tcp';
2355                     }
2356                 }
2357
2358                 $current->{action} = { type => 'target',
2359                                        target => $keyword,
2360                                      };
2361                 next;
2362             }
2363
2364             ###
2365             # protocol specific options
2366             #
2367
2368             my $proto = find_option(\@fw, 'builtin____protocol');
2369             if (defined $proto and not ref $proto) {
2370                 $proto = 'icmpv6' if $proto eq 'ipv6-icmp';
2371                 $proto = 'mh' if $proto eq 'ipv6-mh';
2372
2373                 if ($proto eq 'icmp') {
2374                     my $domains = find_option(\@fw, 'domain');
2375                     $proto = 'icmpv6' if not ref $domains and $domains eq 'ip6';
2376                 }
2377
2378                 parse_protocol_options(\@fw, $current, $proto, $keyword, \$negated)
2379                   and next;
2380             }
2381
2382             # port switches
2383             if ($keyword =~ /^[sd]port$/) {
2384                 error('To use sport or dport, you have to specify "proto tcp" or "proto udp" first')
2385                   unless defined $proto and grep { /^(?:tcp|udp|udplite|dccp|sctp)$/ } to_array $proto;
2386
2387                 $current->{$keyword} = getvalues(undef, undef,
2388                                                  allow_negation => 1);
2389                 next;
2390             }
2391
2392             ###
2393             # module specific options
2394             #
2395
2396             if (keys %modules) {
2397                 parse_module_options(\@fw, $current, \%modules, $keyword, \$negated, $proto)
2398                   and next;
2399             }
2400
2401             ###
2402             # target specific options
2403             #
2404
2405             my $action = find_option(\@fw, 'action');
2406             if (defined $action and $action->{type} eq 'target') {
2407                 parse_target_options(\@fw, $current,
2408                                      $action->{target}, $keyword);
2409                 next;
2410             }
2411
2412             # default
2413             error("Unrecognized keyword: $keyword");
2414         }
2415
2416         # if the rule didn't reset the negated flag, it's not
2417         # supported
2418         error("Doesn't support negation: $keyword")
2419           if $negated;
2420     }
2421
2422     error('Missing "}" at end of file')
2423       if $lev > $base_level;
2424
2425     # consistency check: check if they havn't forgotten
2426     # the ';' before the last statement
2427     error("Missing semicolon before end of file")
2428       if keys %$current;
2429 }
2430
2431 sub check() {
2432     while (my ($domain_name, $domain) = each %domains) {
2433         while (my ($table_name, $table_info) = each %{$domain->{tables}}) {
2434             while (my ($chain_name, $chain) = each %{$table_info->{chains}}) {
2435                 warning("chain $chain_name (domain $domain_name, table $table_name) was referenced, but not declared")
2436                   if $chain->{was_created} and not $chain->{non_empty};
2437             }
2438         }
2439     }
2440 }
2441
2442 sub execute_slow($$) {
2443     my ($domain, $rules) = @_;
2444
2445     my $status;
2446     foreach (reset_domain($domain), @$rules) {
2447         my $script;
2448
2449         if (ref) {
2450             $script = $_->{script};
2451             $_ = $_->{rule};
2452         }
2453
2454         s/^\s+//s;
2455         print LINES $_
2456           if $option{lines};
2457         next if $option{noexec};
2458         next if /^#/;
2459
2460         my $ret = system($_);
2461         unless ($ret == 0) {
2462             if ($? == -1) {
2463                 print STDERR "failed to execute: $!\n";
2464                 exit 1;
2465             } elsif ($? & 0x7f) {
2466                 printf STDERR "child died with signal %d\n", $? & 0x7f;
2467                 $status = 1;
2468             } else {
2469                 print STDERR "(rule declared in $script->{filename}:$script->{line})\n"
2470                   if defined $script;
2471                 $status = $? >> 8;
2472             }
2473         }
2474     }
2475
2476     return $status;
2477 }
2478
2479 sub rules_to_save($$) {
2480     my ($domain, $rules) = @_;
2481
2482     # parse the current ruleset, ignore -X and -F, handle policies and
2483     # custom chains
2484     my %policies;
2485     my %rules;
2486     foreach my $rule (reset_domain($domain), @$rules) {
2487         $rule = $rule->{rule}
2488           if ref $rule;
2489
2490         $rule =~ s/^\S+\s+//;
2491         my $table = $rule =~ s/-t\s+(\w+)\s*//
2492           ? $1 : 'filter';
2493         if ($rule =~ /-P\s+(\S+)\s+(\w+)\s*/) {
2494             $policies{$table}{$1} = $2;
2495         } elsif ($rule =~ /-A\s+(\w+)/) {
2496             push @{$rules{$table}{$1}}, $rule;
2497         } elsif ($rule =~ /-N\s+(\S+)\s*/) {
2498             $policies{$table}{$1} = '-';
2499         }
2500     }
2501
2502     # convert this into an iptables-save text
2503     my $result = "# Generated by ferm $VERSION on " . localtime() . "\n";
2504
2505     foreach my $table (qw(nat filter mangle raw)) {
2506         my $policies = $policies{$table};
2507         my $r = $rules{$table};
2508
2509         next
2510           unless defined $policies or defined $r;
2511
2512         # select table
2513         $result .= '*' . $table . "\n";
2514
2515         # create chains / set policy
2516         if (defined $policies) {
2517             foreach my $chain (sort keys %$policies) {
2518                 my $policy = $policies->{$chain};
2519                 $result .= ":$chain $policy\ [0:0]\n";
2520             }
2521         }
2522
2523         # dump rules
2524         if (defined $r) {
2525             foreach my $chain (sort keys %$r) {
2526                 my $rs = $r->{$chain};
2527                 foreach (@$rs) {
2528                     $result .= $_;
2529                 }
2530             }
2531         }
2532
2533         # do it
2534         $result .= "COMMIT\n";
2535    }
2536
2537     return $result;
2538 }
2539
2540 sub restore_domain($$) {
2541     my ($domain, $save) = @_;
2542
2543     my $path = $domains{$domain}{tools}{'tables-restore'};
2544
2545     local *RESTORE;
2546     open RESTORE, "|$path"
2547       or die "Failed to run $path: $!\n";
2548
2549     print RESTORE $save;
2550
2551     close RESTORE
2552       or die "Failed to run $path\n";
2553 }
2554
2555 sub execute_fast($$) {
2556     my ($domain, $save) = @_;
2557
2558     if ($option{lines}) {
2559         print LINES "$domains{$domain}{tools}{'tables-restore'} <<EOT\n"
2560           if $option{shell};
2561         print LINES $save;
2562         print LINES "EOT\n"
2563           if $option{shell};
2564     }
2565
2566     return if $option{noexec};
2567
2568     eval {
2569         restore_domain($domain, $save);
2570     };
2571     if ($@) {
2572         print STDERR $@;
2573         return 1;
2574     }
2575
2576     return;
2577 }
2578
2579 sub rollback() {
2580     my $error;
2581     foreach my $domain (keys %rules) {
2582         unless (defined $domains{$domain}{tools}{'tables-restore'}) {
2583             print STDERR "Cannot rollback domain '$domain' because there is no ${domain}tables-restore\n";
2584             next;
2585         }
2586
2587         my $reset = '';
2588         while (my ($table, $table_info) = each %{$domains{$domain}{tables}}) {
2589             my $reset_chain = '';
2590             foreach my $chain (keys %{$table_info->{chains}{$table}}) {
2591                 next unless is_netfilter_builtin_chain($table, $chain);
2592                 $reset_chain .= ":${chain} ACCEPT [0:0]\n";
2593             }
2594             $reset .= "*${table}\n${reset_chain}COMMIT\n"
2595               if length $reset_chain;
2596         }
2597
2598         $reset .= $domains{$domain}{previous}
2599           if defined $domains{$domain}{previous};
2600
2601         restore_domain($domain, $reset);
2602     }
2603
2604     print STDERR "\nFirewall rules rolled back.\n" unless $error;
2605     exit 1;
2606 }
2607
2608 sub alrm_handler {
2609     # do nothing, just interrupt a system call
2610 }
2611
2612 sub confirm_rules() {
2613     $SIG{ALRM} = \&alrm_handler;
2614
2615     alarm(5);
2616
2617     print STDERR "\n"
2618       . "ferm has applied the new firewall rules.\n"
2619         . "Please type 'yes' to confirm:\n";
2620     STDERR->flush();
2621
2622     alarm(30);
2623
2624     my $line = '';
2625     STDIN->sysread($line, 3);
2626
2627     eval {
2628         require POSIX;
2629         POSIX::tcflush(*STDIN, 2);
2630     };
2631     print STDERR "$@" if $@;
2632
2633     $SIG{ALRM} = 'DEFAULT';
2634
2635     return $line eq 'yes';
2636 }
2637
2638 # end of ferm
2639
2640 __END__
2641
2642 =head1 NAME
2643
2644 ferm - a firewall rule parser for linux
2645
2646 =head1 SYNOPSIS
2647
2648 B<ferm> I<options> I<inputfiles>
2649
2650 =head1 OPTIONS
2651
2652  -n, --noexec      Do not execute the rules, just simulate
2653  -F, --flush       Flush all netfilter tables managed by ferm
2654  -l, --lines       Show all rules that were created
2655  -i, --interactive Interactive mode: revert if user does not confirm
2656  --remote          Remote mode; ignore host specific configuration.
2657                    This implies --noexec and --lines.
2658  -V, --version     Show current version number
2659  -h, --help        Look at this text
2660  --fast            Generate an iptables-save file, used by iptables-restore
2661  --shell           Generate a shell script which calls iptables-restore
2662  --domain {ip|ip6} Handle only the specified domain
2663  --def '$name=v'   Override a variable
2664
2665 =cut