"Fossies" - the Fresh Open Source Software Archive

Member "ferm-2.5.1/src/ferm" (24 Jan 2020, 99845 Bytes) of package /linux/privat/ferm-2.5.1.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_vs_2.5.1.

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