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