"Fossies" - the Fresh Open Source Software Archive

Member "ferm-2.6/src/ferm" (30 Jan 2021, 103190 Bytes) of package /linux/privat/ferm-2.6.tar.xz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "ferm": 2.5.1_vs_2.6.

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