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