src/ferm

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