← Back to branch summary

~ubuntu-branches/debian/sid/shorewall/sid

« back to all changes in this revision

Viewing changes to Perl/Shorewall/Tc.pm

  • Committer: Package Import Robot
  • Author(s): Roberto C. Sanchez
  • Date: 2013-05-03 08:17:42 UTC
  • mfrom: (1.3.52)
  • Revision ID: package-import@ubuntu.com-20130503081742-qo8p6k2z0dnbfqo8
Tags: 4.5.16.1-1
* New Upstream Version
* debian/patches/01_debian_configuration.patch: Refreshed
* debian/patches/02_correct_dnat_snat_behavior.patch: Removed
* Update lintian overrides

Show diffs side-by-side

added added

removed removed

Lines of Context:
Perl/Shorewall/Tc.pm
3
3
#
4
4
#     This program is under GPL [http://www.gnu.org/licenses/old-licenses/gpl-2.0.txt]
5
5
#
6
 
#     (c) 2007,2008,2009,2010,2011 - Tom Eastep (teastep@shorewall.net)
 
6
#     (c) 2007,2008,2009,2010,2011,2012,2013 - Tom Eastep (teastep@shorewall.net)
7
7
#
8
8
#     Traffic Control is from tc4shorewall Version 0.5
9
9
#     (c) 2005 Arne Bernin <arne@ucbering.de>
40
40
our @ISA = qw(Exporter);
41
41
our @EXPORT = qw( process_tc setup_tc );
42
42
our @EXPORT_OK = qw( process_tc_rule initialize );
43
 
our $VERSION = '4.5_4';
 
43
our $VERSION = '4.5_16';
44
44
 
45
45
my  %tcs = ( T => { chain  => 'tcpost',
46
46
                    connmark => 0,
86
86
               HIGHMARK  => 2
87
87
               };
88
88
 
89
 
my  %flow_keys = ( 'src'            => 1,
 
89
our %flow_keys = ( 'src'            => 1,
90
90
                   'dst'            => 1,
91
91
                   'proto'          => 1,
92
92
                   'proto-src'      => 1,
104
104
                   'sk-gid'         => 1,
105
105
                   'vlan-tag'       => 1 );
106
106
 
107
 
my %designator = ( F => 'tcfor' ,
108
 
                   T => 'tcpost' );
 
107
our %designator = ( F => 'tcfor' ,
 
108
                    T => 'tcpost' );
109
109
 
110
 
my  %tosoptions = ( 'tos-minimize-delay'       => '0x10/0x10' ,
 
110
our %tosoptions = ( 'tos-minimize-delay'       => '0x10/0x10' ,
111
111
                    'tos-maximize-throughput'  => '0x08/0x08' ,
112
112
                    'tos-maximize-reliability' => '0x04/0x04' ,
113
113
                    'tos-minimize-cost'        => '0x02/0x02' ,
114
114
                    'tos-normal-service'       => '0x00/0x1e' );
115
 
my  %classids;
 
115
our %classids;
116
116
 
117
117
#
118
118
# Perl version of Arn Bernin's 'tc4shorewall'.
133
133
#                              name          => <interface>
134
134
#                                               }
135
135
#
136
 
my  @tcdevices;
137
 
my  %tcdevices;
138
 
my  @devnums;
139
 
my  $devnum;
140
 
my  $sticky;
141
 
my  $ipp2p;
 
136
our @tcdevices;
 
137
our %tcdevices;
 
138
our @devnums;
 
139
our $devnum;
 
140
our $sticky;
 
141
our $ipp2p;
142
142
 
143
143
#
144
144
# TCClasses Table
159
159
#                                                }
160
160
#                                     }
161
161
#             }
162
 
my  @tcclasses;
163
 
my  %tcclasses;
 
162
our @tcclasses;
 
163
our %tcclasses;
164
164
 
165
 
my  %restrictions = ( tcpre      => PREROUTE_RESTRICT ,
 
165
our %restrictions = ( tcpre      => PREROUTE_RESTRICT ,
166
166
                      PREROUTING => PREROUTE_RESTRICT ,
167
167
                      tcpost     => POSTROUTE_RESTRICT ,
168
168
                      tcfor      => NO_RESTRICT ,
170
170
                      tcout      => OUTPUT_RESTRICT ,
171
171
                    );
172
172
 
173
 
my $family;
174
 
 
175
 
my $divertref; # DIVERT chain
176
 
 
 
173
our $family;
 
174
 
 
175
our $divertref; # DIVERT chain
 
176
 
 
177
our %validstates = ( NEW                => 0,
 
178
                     RELATED            => 0,
 
179
                     ESTABLISHED        => 0,
 
180
                     UNTRACKED          => 0,
 
181
                     INVALID            => 0,
 
182
                   );
177
183
#
178
184
# Rather than initializing globals in an INIT block or during declaration,
179
185
# we initialize them in a function. This is done for two reasons:
198
204
    $divertref = 0;
199
205
}
200
206
 
201
 
sub process_tc_rule( ) {
202
 
    my ( $originalmark, $source, $dest, $proto, $ports, $sports, $user, $testval, $length, $tos , $connbytes, $helper, $headers, $probability , $dscp );
203
 
    if ( $family == F_IPV4 ) {
204
 
        ( $originalmark, $source, $dest, $proto, $ports, $sports, $user, $testval, $length, $tos , $connbytes, $helper, $probability, $dscp ) =
205
 
            split_line1 'tcrules file', { mark => 0, action => 0, source => 1, dest => 2, proto => 3, dport => 4, sport => 5, user => 6, test => 7, length => 8, tos => 9, connbytes => 10, helper => 11, probability => 12 , dscp => 13 }, { COMMENT => 0, FORMAT => 2 } , 14;
206
 
        $headers = '-';
207
 
    } else {
208
 
        ( $originalmark, $source, $dest, $proto, $ports, $sports, $user, $testval, $length, $tos , $connbytes, $helper, $headers, $probability, $dscp ) =
209
 
            split_line1 'tcrules file', { mark => 0, action => 0, source => 1, dest => 2, proto => 3, dport => 4, sport => 5, user => 6, test => 7, length => 8, tos => 9, connbytes => 10, helper => 11, headers => 12, probability => 13 , dscp => 14 },  { COMMENT => 0, FORMAT => 2 }, 15;
 
207
sub process_tc_rule1( $$$$$$$$$$$$$$$$ ) {
 
208
    my ( $originalmark, $source, $dest, $proto, $ports, $sports, $user, $testval, $length, $tos , $connbytes, $helper, $headers, $probability , $dscp , $state ) = @_;
 
209
 
 
210
our  %tccmd;
 
211
 
 
212
    unless ( %tccmd ) {
 
213
        %tccmd = ( SAVE =>     { match     => sub ( $ ) { $_[0] eq 'SAVE' } ,
 
214
                                 target    => 'CONNMARK --save-mark --mask' ,
 
215
                                 mark      => $config{TC_EXPERT} ? HIGHMARK : SMALLMARK,
 
216
                                 mask      => in_hex( $globals{TC_MASK} ) ,
 
217
                                 connmark  => 1
 
218
                               } ,
 
219
                   RESTORE =>  { match     => sub ( $ ) { $_[0] eq 'RESTORE' },
 
220
                                 target    => 'CONNMARK --restore-mark --mask' ,
 
221
                                 mark      => $config{TC_EXPERT} ? HIGHMARK : SMALLMARK ,
 
222
                                 mask      => in_hex( $globals{TC_MASK} ) ,
 
223
                                 connmark  => 1
 
224
                               } ,
 
225
                   CONTINUE => { match     => sub ( $ ) { $_[0] eq 'CONTINUE' },
 
226
                                 target    => 'RETURN' ,
 
227
                                 mark      => NOMARK ,
 
228
                                 mask      => '' ,
 
229
                                 connmark  => 0
 
230
                               } ,
 
231
                   SAME =>     { match     => sub ( $ ) { $_[0] eq 'SAME' },
 
232
                                 target    => 'sticky' ,
 
233
                                 mark      => NOMARK ,
 
234
                                 mask      => '' ,
 
235
                                 connmark  => 0
 
236
                               } ,
 
237
                   IPMARK =>   { match     => sub ( $ ) { $_[0] =~ /^IPMARK/ },
 
238
                                 target    => 'IPMARK' ,
 
239
                                 mark      => NOMARK,
 
240
                                 mask      => '',
 
241
                                 connmark  => 0
 
242
                               } ,
 
243
                   '|' =>      { match     => sub ( $ ) { $_[0] =~ '\|.*'} ,
 
244
                                 target    => 'MARK --or-mark' ,
 
245
                                 mark      => HIGHMARK ,
 
246
                                 mask      => ''
 
247
                               } ,
 
248
                   '&' =>      { match     => sub ( $ ) { $_[0] =~ '&.*' },
 
249
                                 target    => 'MARK --and-mark' ,
 
250
                                 mark      => HIGHMARK ,
 
251
                                 mask      => '' ,
 
252
                                 connmark  => 0
 
253
                               } ,
 
254
                   TPROXY =>   { match     => sub ( $ ) { $_[0] =~ /^TPROXY/ },
 
255
                                 target    => 'TPROXY',
 
256
                                 mark      => HIGHMARK,
 
257
                                 mask      => '',
 
258
                                 connmark  => ''
 
259
                               },
 
260
                   DIVERT =>   { match     => sub( $ ) { $_[0] =~ /^DIVERT/ },
 
261
                                 target    => 'DIVERT',
 
262
                                 mark      => HIGHMARK,
 
263
                                 mask      => '',
 
264
                                 connmark  => ''
 
265
                               },
 
266
                   TTL =>      { match     => sub( $ ) { $_[0] =~ /^TTL/ },
 
267
                                 target    => 'TTL',
 
268
                                 mark      => NOMARK,
 
269
                                 mask      => '',
 
270
                                 connmark  => 0
 
271
                               },
 
272
                   HL =>       { match     => sub( $ ) { $_[0] =~ /^HL/ },
 
273
                                 target    => 'HL',
 
274
                                 mark      => NOMARK,
 
275
                                 mask      => '',
 
276
                                 connmark  => 0
 
277
                               },
 
278
                   IMQ =>      { match     => sub( $ ) { $_[0] =~ /^IMQ\(\d+\)$/ },
 
279
                                 target    => 'IMQ',
 
280
                                 mark      => NOMARK,
 
281
                                 mask      => '',
 
282
                                 connmark  => 0
 
283
                               },
 
284
                   DSCP =>     { match     => sub( $ ) { $_[0] =~ /^DSCP\(\w+\)$/ },
 
285
                                 target    => 'DSCP',
 
286
                                 mark      => NOMARK,
 
287
                                 mask      => '',
 
288
                                 connmark  => 0
 
289
                               },
 
290
                   TOS =>      { match     => sub( $ ) { $_[0] =~ /^TOS\(.+\)$/ },
 
291
                                 target    => 'TOS',
 
292
                                 mark      => NOMARK,
 
293
                                 mask      => '',
 
294
                                 connmark  => 0
 
295
                               },
 
296
                   CHECKSUM => { match     => sub( $ ) { $_[0] eq 'CHECKSUM' },
 
297
                                 target    => 'CHECKSUM' ,
 
298
                                 mark      => NOMARK,
 
299
                                 mask      => '',
 
300
                                 connmark  => 0,
 
301
                               },
 
302
                   INLINE   => { match     => sub( $ ) { $_[0] eq 'INLINE' },
 
303
                                 target    => 'INLINE',
 
304
                                 mark      => NOMARK,
 
305
                                 mask      => '',
 
306
                                 connmark  => 0,
 
307
                               }
 
308
                 );
210
309
    }
211
310
 
212
 
    our @tccmd;
213
 
 
214
 
    our $format;
215
 
 
216
311
    fatal_error 'MARK must be specified' if $originalmark eq '-';
217
312
 
218
 
    if ( $originalmark eq 'COMMENT' ) {
219
 
        process_comment;
220
 
        return;
221
 
    }
222
 
 
223
 
    if ( $originalmark eq 'FORMAT' ) {
224
 
        if ( $source =~ /^([12])$/ ) {
225
 
            $format = $1;
226
 
            return;
227
 
        }
228
 
 
229
 
        fatal_error "Invalid FORMAT ($source)";
230
 
    }
231
 
 
232
313
    my ( $mark, $designator, $remainder ) = split( /:/, $originalmark, 3 );
233
314
 
234
315
    fatal_error "Invalid MARK ($originalmark)" unless supplied $mark;
259
340
    my $cmd;
260
341
    my $rest;
261
342
    my $matches = '';
 
343
    my $mark1;
 
344
    my $exceptionrule = '';
262
345
 
263
346
    my %processtcc = ( sticky => sub() {
264
347
                                          if ( $chain eq 'tcout' ) {
312
395
                                          $target = "IPMARK --addr $srcdst --and-mask $mask1 --or-mask $mask2 --shift $shift";
313
396
                                      },
314
397
                       DIVERT => sub() {
315
 
                                          fatal_error "Invalid MARK ($originalmark)"               unless $format == 2;
 
398
                                          fatal_error "Invalid MARK ($originalmark)"               unless $file_format == 2;
316
399
                                          fatal_error "Invalid DIVERT specification( $cmd/$rest )" if $rest;
317
400
 
318
401
                                          $chain = 'PREROUTING';
341
424
                                          my $params = $1;
342
425
                                          my ( $port, $ip, $bad );
343
426
 
344
 
                                          if ( $format == 1 ) {
 
427
                                          if ( $file_format == 1 ) {
345
428
                                              fatal_error "Invalid TPROXY specification( $cmd )" unless defined $params;
346
429
 
347
430
                                              ( $mark, $port, $ip, $bad ) = split_list $params, 'Parameter';
372
455
 
373
456
                                          if ( supplied $ip ) {
374
457
                                              if ( $family == F_IPV6 ) {
375
 
                                                  $ip = $1 if $ip =~ /^\[(.+)\]$/ || $ip =~ /^<(.+)>$/;
 
458
                                                  if ( $ip =~ /^\[(.+)\]$/ || $ip =~ /^<(.+)>$/ ) {
 
459
                                                      $ip = $1;
 
460
                                                  } elsif ( $ip =~ /^\[(.+)\]\/(\d+)$/ ) {
 
461
                                                      $ip = join( $1, $2 );
 
462
                                                  }
376
463
                                              }
377
464
 
378
465
                                              validate_address $ip, 1;
380
467
                                          }
381
468
 
382
469
                                          $target .= ' --tproxy-mark';
 
470
 
 
471
                                          $exceptionrule = '-p tcp ';
383
472
                                      },
384
473
                       TTL => sub() {
385
474
                                          fatal_error "TTL is not supported in IPv6 - use HL instead" if $family == F_IPV6;
386
475
                                          fatal_error "Invalid TTL specification( $cmd/$rest )" if $rest;
387
 
                                          fatal_error "Chain designator $designator not allowed with TTL" if $designator && ! ( $designator eq 'F' );
388
 
 
389
476
                                          $chain = 'tcfor';
390
477
 
391
 
                                          $cmd =~ /^TTL\(([-+]?\d+)\)$/;
 
478
                                          if ( $designator ) {
 
479
                                              if ( $designator eq 'P' ) {
 
480
                                                  $chain = 'tcpre';
 
481
                                              } else {
 
482
                                                  fatal_error "Chain designator $designator not allowed with TTL" if $designator ne 'F';
 
483
                                              }
 
484
                                          }
 
485
 
 
486
                                          $cmd =~ /^TTL\(([-+]?(\d+))\)$/;
392
487
 
393
488
                                          my $param =  $1;
394
489
 
395
 
                                          fatal_error "Invalid TTL specification( $cmd )" unless $param && ( $param = abs $param ) < 256;
 
490
                                          fatal_error "Invalid TTL specification( $cmd )" unless supplied( $1 ) && ( $1 eq $2 || $2 != 0 ) && ( $param = abs $param ) < 256;
396
491
 
397
492
                                          if ( $1 =~ /^\+/ ) {
398
493
                                              $target .= " --ttl-inc $param";
405
500
                       HL => sub() {
406
501
                                          fatal_error "HL is not supported in IPv4 - use TTL instead" if $family == F_IPV4;
407
502
                                          fatal_error "Invalid HL specification( $cmd/$rest )" if $rest;
408
 
                                          fatal_error "Chain designator $designator not allowed with HL" if $designator && ! ( $designator eq 'F' );
409
 
 
410
503
                                          $chain = 'tcfor';
411
504
 
412
 
                                          $cmd =~ /^HL\(([-+]?\d+)\)$/;
 
505
 
 
506
                                          if ( $designator ) {
 
507
                                              if ( $designator eq 'P' ) {
 
508
                                                  $chain = 'tcpre';
 
509
                                              } else {
 
510
                                                  fatal_error "Chain designator $designator not allowed with HL" if $designator ne 'F';
 
511
                                              }
 
512
                                          }
 
513
 
 
514
                                          $cmd =~ /^HL\(([-+]?(\d+))\)$/;
413
515
 
414
516
                                          my $param =  $1;
415
517
 
416
 
                                          fatal_error "Invalid HL specification( $cmd )" unless $param && ( $param = abs $param ) < 256;
 
518
                                          fatal_error "Invalid HL specification( $cmd )" unless supplied( $1 ) && ( $1 eq $2 || $2 != 0 ) && ( $param = abs $param ) < 256;
417
519
 
418
520
                                          if ( $1 =~ /^\+/ ) {
419
521
                                              $target .= " --hl-inc $param";
440
542
                                          assert( $cmd =~ /^TOS\((.+)\)$/ );
441
543
                                          $target .= decode_tos( $1 , 2 );
442
544
                                      },
 
545
                       CHECKSUM => sub()
 
546
                                        {  require_capability 'CHECKSUM_TARGET', 'The CHECKSUM action', 's';
 
547
                                           $target .= ' --checksum-fill';
 
548
                                       },
 
549
                       INLINE   => sub()
 
550
                                       {
 
551
                                           assert ( $cmd eq 'INLINE' );
 
552
                                           $matches = get_inline_matches;
 
553
 
 
554
                                           if ( $matches =~ /^(.*\s+)-j\s+(.+)$/ ) {
 
555
                                               $matches = $1;
 
556
                                               $target  = $2;
 
557
                                           }
 
558
 
 
559
                                           $cmd = '';
 
560
                                       }
443
561
                     );
444
562
 
445
563
    if ( $source ) {
480
598
 
481
599
            $chain    = $tcsref->{chain}                       if $tcsref->{chain};
482
600
            $target   = $tcsref->{target}                      if $tcsref->{target};
483
 
            $mark     = "$mark/" . in_hex( $globals{TC_MASK} ) if $connmark = $tcsref->{connmark};
 
601
            $mark     = "$mark/" . in_hex( $globals{TC_MASK} ) if $connmark = $tcsref->{connmark} && $mark !~ m'/';
484
602
 
485
603
            require_capability ('CONNMARK' , "CONNMARK Rules", '' ) if $connmark;
486
604
 
487
605
        } else {
488
606
            unless ( $classid ) {
489
 
                fatal_error "Invalid MARK ($originalmark)" unless $mark =~ /^([0-9a-fA-F]+)$/ and $designator =~ /^([0-9a-fA-F]+)$/;
 
607
                fatal_error "Invalid ACTION ($originalmark)" unless $mark =~ /^([0-9a-fA-F]+)$/ and $designator =~ /^([0-9a-fA-F]+)$/;
490
608
                fatal_error 'A CLASSIFY rule may not have $FW as the DEST' if $chain eq 'tcin';
491
609
                $chain = 'tcpost';
492
610
                $mark  = $originalmark;
524
642
    $list = '';
525
643
 
526
644
    unless ( $classid ) {
527
 
      MARK:
528
645
        {
529
 
            for my $tccmd ( @tccmd ) {
530
 
                if ( $tccmd->{match}($cmd) ) {
 
646
            if ( $cmd =~ /^([[A-Z!&]+)/ ) {
 
647
                if ( my $tccmd = $tccmd{$1} ) {
 
648
                    fatal_error "Invalid $1 ACTION ($originalmark)" unless $tccmd->{match}($cmd); 
531
649
                    fatal_error "$mark not valid with :C[FPT]" if $connmark;
532
650
 
533
651
                    require_capability ('CONNMARK' , "SAVE/RESTORE Rules", '' ) if $tccmd->{connmark};
546
664
                    }
547
665
 
548
666
                    if ( $rest ) {
549
 
                        fatal_error "Invalid MARK ($originalmark)" if $marktype == NOMARK;
 
667
                        fatal_error "Invalid COMMAND ($originalmark)" if $marktype == NOMARK;
550
668
 
551
669
                        $mark = $rest if $tccmd->{mask};
552
670
 
558
676
                    } elsif ( $tccmd->{mask} ) {
559
677
                        $mark = $tccmd->{mask};
560
678
                    }
561
 
 
562
 
                    last MARK;
 
679
                } else {
 
680
                    fatal_error "Invalid ACTION ($originalmark)";
563
681
                }
564
 
            }
565
 
 
566
 
            validate_mark $mark;
567
 
 
568
 
            if ( $config{PROVIDER_OFFSET} ) {
569
 
                my $val = numeric_value( $cmd );
570
 
                fatal_error "Invalid MARK/CLASSIFY ($cmd)" unless defined $val;
571
 
                my $limit = $globals{TC_MASK};
572
 
                unless ( have_capability 'FWMARK_RT_MASK' ) {
573
 
                    fatal_error "Marks <= $limit may not be set in the PREROUTING or OUTPUT chains when HIGH_ROUTE_MARKS=Yes"
574
 
                        if $cmd && ( $chain eq 'tcpre' || $chain eq 'tcout' ) && $val <= $limit;
 
682
            } elsif ( $mark =~ /-/ ) {
 
683
                ( $mark, $mark1 ) = split /-/, $mark, 2;
 
684
                validate_mark $mark;
 
685
                fatal_error "Invalid mark range ($mark-$mark1)" if $mark =~ m'/';
 
686
                validate_mark $mark1;
 
687
                require_capability 'STATISTIC_MATCH', 'A mark range', 's';
 
688
            }  else {
 
689
                validate_mark $mark;
 
690
 
 
691
                if ( $config{PROVIDER_OFFSET} ) {
 
692
                    my $val = numeric_value( $cmd );
 
693
                    fatal_error "Invalid MARK/CLASSIFY ($cmd)" unless defined $val;
 
694
                    my $limit = $globals{TC_MASK};
 
695
                    unless ( have_capability 'FWMARK_RT_MASK' ) {
 
696
                        fatal_error "Marks <= $limit may not be set in the PREROUTING or OUTPUT chains when HIGH_ROUTE_MARKS=Yes"
 
697
                            if $cmd && ( $chain eq 'tcpre' || $chain eq 'tcout' ) && $val <= $limit;
 
698
                    }
575
699
                }
576
700
            }
577
701
        }
579
703
 
580
704
    fatal_error "USER/GROUP only allowed in the OUTPUT chain" unless ( $user eq '-' || ( $chain eq 'tcout' || $chain eq 'tcpost' ) );
581
705
 
582
 
    if ( ( my $result = expand_rule( ensure_chain( 'mangle' , $chain ) ,
583
 
                                     $restrictions{$chain} | $restriction,
584
 
                                     do_proto( $proto, $ports, $sports) . $matches .
585
 
                                     do_user( $user ) .
586
 
                                     do_test( $testval, $globals{TC_MASK} ) .
587
 
                                     do_length( $length ) .
588
 
                                     do_tos( $tos ) .
589
 
                                     do_connbytes( $connbytes ) .
590
 
                                     do_helper( $helper ) .
591
 
                                     do_headers( $headers ) .
592
 
                                     do_probability( $probability ) .
593
 
                                     do_dscp( $dscp ) ,
594
 
                                     $source ,
595
 
                                     $dest ,
596
 
                                     '' ,
597
 
                                     $mark ? "$target $mark" : $target,
598
 
                                     '' ,
599
 
                                     $target ,
600
 
                                     '' ) )
601
 
          && $device ) {
 
706
    if ( $state ne '-' ) {
 
707
        my @state = split_list( $state, 'state' );
 
708
        my %state = %validstates;
 
709
 
 
710
        for ( @state ) {
 
711
            fatal_error "Invalid STATE ($_)"   unless exists $state{$_};
 
712
            fatal_error "Duplicate STATE ($_)" if $state{$_};
 
713
        }
 
714
    } else {
 
715
        $state = 'ALL';
 
716
    }
 
717
 
 
718
    if ( $mark1 ) {
 
719
        #
 
720
        # A Mark Range
 
721
        #
 
722
        my $chainref = ensure_chain( 'mangle', $chain );
 
723
 
 
724
        ( $mark1, my $mask ) = split( '/', $mark1 );
 
725
 
 
726
        my ( $markval, $mark1val ) = ( numeric_value $mark, numeric_value $mark1 );
 
727
 
 
728
        fatal_error "Invalid mark range ($mark-$mark1)" unless $markval < $mark1val;
 
729
 
 
730
        $mask = $globals{TC_MASK} unless supplied $mask;
 
731
 
 
732
        $mask = numeric_value $mask;
 
733
 
 
734
        my $increment = 1;
 
735
        my $shift     = 0;
 
736
 
 
737
        $increment <<= 1, $shift++ until $increment & $mask;
 
738
 
 
739
        $mask = in_hex $mask;
 
740
 
 
741
        my $marks = ( ( $mark1val - $markval ) >> $shift ) + 1;
 
742
 
 
743
        for ( my $packet = 0; $packet < $marks; $packet++, $markval += $increment ) {
 
744
            my $match = "-m statistic --mode nth --every $marks --packet $packet ";
 
745
 
 
746
            expand_rule( $chainref,
 
747
                         $restrictions{$chain} | $restriction,
 
748
                         '' ,
 
749
                         $match .
 
750
                         do_user( $user ) .
 
751
                         do_test( $testval, $globals{TC_MASK} ) .
 
752
                         do_test( $testval, $globals{TC_MASK} ) .
 
753
                         do_length( $length ) .
 
754
                         do_tos( $tos ) .
 
755
                         do_connbytes( $connbytes ) .
 
756
                         do_helper( $helper ) .
 
757
                         do_headers( $headers ) .
 
758
                         do_probability( $probability ) .
 
759
                         do_dscp( $dscp ) .
 
760
                         state_match( $state ) ,
 
761
                         $source ,
 
762
                         $dest ,
 
763
                         '' ,
 
764
                         "$target " . join( '/', in_hex( $markval ) , $mask ) ,
 
765
                         '',
 
766
                         $target ,
 
767
                         $exceptionrule );
 
768
        }
 
769
    } elsif ( ( my $result = expand_rule( ensure_chain( 'mangle' , $chain ) ,
 
770
                                          $restrictions{$chain} | $restriction,
 
771
                                          '',
 
772
                                          do_proto( $proto, $ports, $sports) . $matches .
 
773
                                          do_user( $user ) .
 
774
                                          do_test( $testval, $globals{TC_MASK} ) .
 
775
                                          do_length( $length ) .
 
776
                                          do_tos( $tos ) .
 
777
                                          do_connbytes( $connbytes ) .
 
778
                                          do_helper( $helper ) .
 
779
                                          do_headers( $headers ) .
 
780
                                          do_probability( $probability ) .
 
781
                                          do_dscp( $dscp ) .
 
782
                                          state_match( $state ) ,
 
783
                                          $source ,
 
784
                                          $dest ,
 
785
                                          '' ,
 
786
                                          $mark ? "$target $mark" : $target,
 
787
                                          '' ,
 
788
                                          $target ,
 
789
                                          $exceptionrule ) )
 
790
              && $device ) {
602
791
        #
603
792
        # expand_rule() returns destination device if any
604
793
        #
609
798
 
610
799
}
611
800
 
 
801
sub process_tc_rule( ) {
 
802
    my ( $originalmark, $source, $dest, $protos, $ports, $sports, $user, $testval, $length, $tos , $connbytes, $helper, $headers, $probability , $dscp , $state );
 
803
    if ( $family == F_IPV4 ) {
 
804
        ( $originalmark, $source, $dest, $protos, $ports, $sports, $user, $testval, $length, $tos , $connbytes, $helper, $probability, $dscp, $state ) =
 
805
            split_line1 'tcrules file', { mark => 0, action => 0, source => 1, dest => 2, proto => 3, dport => 4, sport => 5, user => 6, test => 7, length => 8, tos => 9, connbytes => 10, helper => 11, probability => 12 , dscp => 13, state => 14 }, {}, 15;
 
806
        $headers = '-';
 
807
    } else {
 
808
        ( $originalmark, $source, $dest, $protos, $ports, $sports, $user, $testval, $length, $tos , $connbytes, $helper, $headers, $probability, $dscp, $state ) =
 
809
            split_line1 'tcrules file', { mark => 0, action => 0, source => 1, dest => 2, proto => 3, dport => 4, sport => 5, user => 6, test => 7, length => 8, tos => 9, connbytes => 10, helper => 11, headers => 12, probability => 13 , dscp => 14 , state => 15 }, {}, 16;
 
810
    }
 
811
 
 
812
    for my $proto (split_list( $protos, 'Protocol' ) ) {
 
813
        process_tc_rule1( $originalmark, $source, $dest, $proto, $ports, $sports, $user, $testval, $length, $tos , $connbytes, $helper, $headers, $probability , $dscp , $state );
 
814
    }
 
815
}
 
816
 
612
817
sub rate_to_kbit( $ ) {
613
818
    my $rate = $_[0];
614
819
 
739
944
    fatal_error "Unknown interface( $device )" unless known_interface $device;
740
945
 
741
946
    my $physical = physical_name $device;
742
 
    my $dev      = chain_base( $physical );
 
947
    my $dev      = var_base( $physical );
743
948
 
744
949
    push @tcdevices, $device;
745
950
 
820
1025
    }
821
1026
 
822
1027
    for ( my $i = 1; $i <= 3; $i++ ) {
 
1028
        my $prio = 16 | $i;
823
1029
        emit "run_tc qdisc add dev $physical parent $number:$i handle ${number}${i}: sfq quantum 1875 limit 127 perturb 10";
824
 
        emit "run_tc filter add dev $physical protocol all prio 2 parent $number: handle $i fw classid $number:$i";
 
1030
        emit "run_tc filter add dev $physical protocol all prio $prio parent $number: handle $i fw classid $number:$i";
825
1031
        emit "run_tc filter add dev $physical protocol all prio 1 parent ${number}$i: handle ${number}${i} flow hash keys $type divisor 1024" if $type ne '-' && have_capability 'FLOW_FILTER';
826
1032
        emit '';
827
1033
    }
853
1059
    progress_message "  Simple tcdevice \"$currentline\" $done.";
854
1060
}
855
1061
 
 
1062
my %validlinklayer = ( ethernet => 1, atm => 1, adsl => 1 );
 
1063
 
856
1064
sub validate_tc_device( ) {
857
1065
    my ( $device, $inband, $outband , $options , $redirected ) = split_line 'tcdevices', { interface => 0, in_bandwidth => 1, out_bandwidth => 2, options => 3, redirect => 4 };
858
1066
 
887
1095
    fatal_error "Duplicate INTERFACE ($device)"    if $tcdevices{$device};
888
1096
    fatal_error "Invalid INTERFACE name ($device)" if $device =~ /[:+]/;
889
1097
 
890
 
    my ( $classify, $pfifo, $flow, $qdisc )  = (0, 0, '', 'htb' );
 
1098
    my ( $classify, $pfifo, $flow, $qdisc, $linklayer, $overhead, $mtu, $mpu, $tsize ) = 
 
1099
        (0,         0,      '',    'htb',  '',         0,         0,    0,    0);
891
1100
 
892
1101
    if ( $options ne '-' ) {
893
1102
        for my $option ( split_list1 $options, 'option' ) {
903
1112
                $qdisc = 'hfsc';
904
1113
            } elsif ( $option eq 'htb' ) {
905
1114
                $qdisc = 'htb';
 
1115
            } elsif ( $option =~ /^linklayer=([a-z]+)$/ ) {
 
1116
                $linklayer = $1;
 
1117
                fatal_error "Invalid linklayer ($linklayer)" unless $validlinklayer{ $linklayer };
 
1118
            } elsif ( $option =~ /^overhead=(.+)$/ ) {
 
1119
                $overhead = numeric_value( $1 );
 
1120
                fatal_error "Invalid overhead ($1)" unless defined $overhead;
 
1121
                fatal_error q('overhead' requires 'linklayer') unless $linklayer; 
 
1122
            } elsif ( $option =~ /^mtu=(.+)$/ ) {
 
1123
                $mtu = numeric_value( $1 );
 
1124
                fatal_error "Invalid mtu ($1)" unless defined $mtu;
 
1125
                fatal_error q('mtu' requires 'linklayer') unless $linklayer; 
 
1126
            } elsif ( $option =~ /^mpu=(.+)$/ ) {
 
1127
                $mpu = numeric_value( $1 );
 
1128
                fatal_error "Invalid mpu ($1)" unless defined $mpu;
 
1129
                fatal_error q('mpu' requires 'linklayer') unless $linklayer;
 
1130
            } elsif ( $option =~ /^tsize=(.+)$/ ) {
 
1131
                $tsize = numeric_value( $1 );
 
1132
                fatal_error "Invalid tsize ($1)" unless defined $tsize;
 
1133
                fatal_error q('tsize' requires 'linklayer') unless $linklayer; 
906
1134
            } else {
907
1135
                fatal_error "Unknown device option ($option)";
908
1136
            }
941
1169
                            guarantee     => 0,
942
1170
                            name          => $device,
943
1171
                            physical      => physical_name $device,
944
 
                            filters       => []
 
1172
                            filters       => [],
 
1173
                            linklayer     => $linklayer,
 
1174
                            overhead      => $overhead,
 
1175
                            mtu           => $mtu,
 
1176
                            mpu           => $mpu,
 
1177
                            tsize         => $tsize,
 
1178
                            filterpri     => 0,
945
1179
                          } ,
946
1180
 
947
1181
    push @tcdevices, $device;
975
1209
    my $delay = shift;
976
1210
 
977
1211
    return 0 unless $delay;
978
 
    return $1 if $delay =~ /^(\d+)(ms)?$/;
 
1212
    return $1 if $delay =~ /^(\d+(\.\d+)?)(ms)?$/;
979
1213
    fatal_error "Invalid Delay ($delay)";
980
1214
}
981
1215
 
1004
1238
    ( $dev , $devref );
1005
1239
}
1006
1240
 
 
1241
use constant { RED_INTEGER => 1, RED_FLOAT => 2, RED_NONE => 3 };
 
1242
 
 
1243
my %validredoptions = ( min         => RED_INTEGER,
 
1244
                        max         => RED_INTEGER,
 
1245
                        limit       => RED_INTEGER,
 
1246
                        burst       => RED_INTEGER,
 
1247
                        avpkt       => RED_INTEGER,
 
1248
                        bandwidth   => RED_INTEGER,
 
1249
                        probability => RED_FLOAT,
 
1250
                        ecn         => RED_NONE,
 
1251
                      );
 
1252
 
 
1253
use constant { CODEL_INTEGER => 1, CODEL_INTERVAL => 2, CODEL_NONE => 3 };
 
1254
 
 
1255
my %validcodeloptions = ( flows       => CODEL_INTEGER,
 
1256
                          target      => CODEL_INTERVAL,
 
1257
                          interval    => CODEL_INTERVAL,
 
1258
                          limit       => CODEL_INTEGER,
 
1259
                          ecn         => CODEL_NONE,
 
1260
                          noecn       => CODEL_NONE,
 
1261
                          quantum     => CODEL_INTEGER
 
1262
                        );
 
1263
 
 
1264
sub validate_filter_priority( $$ ) {
 
1265
    my ( $priority, $kind ) = @_;
 
1266
 
 
1267
    my $pri = numeric_value( $priority );
 
1268
 
 
1269
    fatal_error "Invalid $kind priority ($priority)" unless defined $pri && $pri > 0 && $pri <= 65535;
 
1270
 
 
1271
    $pri;
 
1272
}
 
1273
 
1007
1274
sub validate_tc_class( ) {
1008
1275
    my ( $devclass, $mark, $rate, $ceil, $prio, $options ) =
1009
1276
        split_line 'tcclasses file', { interface => 0, mark => 1, rate => 2, ceil => 3, prio => 4, options => 5 };
1013
1280
    my $occurs = 1;
1014
1281
    my $parentclass = 1;
1015
1282
    my $parentref;
 
1283
    my $lsceil = 0;
1016
1284
 
1017
1285
    fatal_error 'INTERFACE must be specified' if $devclass eq '-';
1018
1286
    fatal_error 'CEIL must be specified'      if $ceil eq '-';
1056
1324
 
1057
1325
    my $tcref = $tcclasses{$device};
1058
1326
 
1059
 
    my $markval = 0;
 
1327
    if ( $devref->{qdisc} eq 'htb' ) {
 
1328
        fatal_error "Invalid PRIO ($prio)" unless defined numeric_value $prio;
 
1329
    }
 
1330
 
 
1331
    my $markval  = 0;
 
1332
    my $markprio;
1060
1333
 
1061
1334
    if ( $mark ne '-' ) {
1062
 
        if ( $devref->{classify} ) {
1063
 
            warning_message "INTERFACE $device has the 'classify' option - MARK value ($mark) ignored";
1064
 
        } else {
1065
 
            fatal_error "MARK may not be specified when TC_BITS=0" unless $config{TC_BITS};
1066
 
 
1067
 
            $markval = numeric_value( $mark );
1068
 
            fatal_error "Invalid MARK ($markval)" unless defined $markval;
1069
 
 
1070
 
            fatal_error "Invalid Mark ($mark)" unless $markval <= $globals{TC_MAX};
1071
 
 
1072
 
            if ( $classnumber ) {
1073
 
                fatal_error "Duplicate Class NUMBER ($classnumber)" if $tcref->{$classnumber};
1074
 
            } else {
1075
 
                $classnumber = $config{TC_BITS} >= 14 ? $devref->{nextclass}++ : hex_value( $devnum . $markval );
1076
 
                fatal_error "Duplicate MARK ($mark)" if $tcref->{$classnumber};
1077
 
            }
 
1335
        fatal_error "MARK may not be specified when TC_BITS=0" unless $config{TC_BITS};
 
1336
 
 
1337
        ( $mark, my $priority ) = split/:/, $mark, 2;
 
1338
 
 
1339
        if ( supplied $priority ) {
 
1340
            $markprio = validate_filter_priority( $priority, 'mark' );
 
1341
        } else {
 
1342
            fatal_error "Missing mark priority" if $prio eq '-';
 
1343
            $markprio =  ( $prio << 8 ) | 20;
 
1344
            progress_message2 "   Priority of the $device packet mark $mark filter is $markprio";
 
1345
        }
 
1346
 
 
1347
        $markval = numeric_value( $mark );
 
1348
        fatal_error "Invalid MARK ($markval)" unless defined $markval;
 
1349
 
 
1350
        fatal_error "Invalid Mark ($mark)" unless $markval <= $globals{TC_MAX};
 
1351
 
 
1352
        if ( $classnumber ) {
 
1353
            fatal_error "Duplicate Class NUMBER ($classnumber)" if $tcref->{$classnumber};
 
1354
        } else {
 
1355
            $classnumber = $config{TC_BITS} >= 14 ? $devref->{nextclass}++ : hex_value( $devnum . $markval );
 
1356
            fatal_error "Duplicate MARK ($mark)" if $tcref->{$classnumber};
1078
1357
        }
1079
1358
    } else {
1080
1359
        fatal_error "Duplicate Class NUMBER ($classnumber)" if $tcref->{$classnumber};
1089
1368
        my $parentnum = in_hexp $parentclass;
1090
1369
        fatal_error "Unknown Parent class ($parentnum)" unless $parentref && $parentref->{occurs} == 1;
1091
1370
        fatal_error "The class ($parentnum) specifies UMAX and/or DMAX; it cannot serve as a parent" if $parentref->{dmax};
1092
 
        fatal_error "The class ($parentnum) specifies flow; it cannot serve as a parent"             if $parentref->{flow};
 
1371
        fatal_error "The class ($parentnum) specifies 'flow'; it cannot serve as a parent"           if $parentref->{flow};
 
1372
        fatal_error "The class ($parentnum) specifies 'red'; it cannot serve as a parent "           if $parentref->{red};
 
1373
        fatal_error "The class ($parentnum) has an 'ls' curve; it cannot serve as a parent "         if $parentref->{lsceil};
1093
1374
        fatal_error "The default class ($parentnum) may not have sub-classes"                        if ( $devref->{default} || 0 ) == $parentclass;
1094
1375
        $parentref->{leaf} = 0;
1095
1376
        $ratemax  = $parentref->{rate};
1100
1381
 
1101
1382
    my ( $umax, $dmax ) = ( '', '' );
1102
1383
 
 
1384
    if ( $ceil =~ /^(.+):(.+)/ ) {
 
1385
        fatal_error "An LS rate may only be specified for HFSC classes" unless $devref->{qdisc} eq 'hfsc';
 
1386
        $lsceil = $1;
 
1387
        $ceil   = $2;
 
1388
    }
 
1389
 
1103
1390
    if ( $devref->{qdisc} eq 'hfsc' ) {
1104
 
        ( my $trate , $dmax, $umax , my $rest ) = split ':', $rate , 4;
1105
 
 
1106
 
        fatal_error "Invalid RATE ($rate)" if defined $rest;
1107
 
 
1108
 
        $rate = convert_rate ( $ratemax, $trate, 'RATE', $ratename );
1109
 
        $dmax = convert_delay( $dmax );
1110
 
        $umax = convert_size( $umax );
1111
 
        fatal_error "DMAX must be specified when UMAX is specified" if $umax && ! $dmax;
1112
 
        $parentclass ||= 1;
 
1391
        if ( $rate eq '-' ) {
 
1392
            fatal_error 'A RATE must be supplied' unless $lsceil;
 
1393
            $rate = 0;
 
1394
        } else {
 
1395
            ( my $trate , $dmax, $umax , my $rest ) = split ':', $rate , 4;
 
1396
 
 
1397
            fatal_error "Invalid RATE ($rate)" if defined $rest;
 
1398
 
 
1399
            $rate = convert_rate ( $ratemax, $trate, 'RATE', $ratename );
 
1400
            $dmax = convert_delay( $dmax );
 
1401
            $umax = convert_size( $umax );
 
1402
            fatal_error "DMAX must be specified when UMAX is specified" if $umax && ! $dmax;
 
1403
            $parentclass ||= 1;
 
1404
        }
1113
1405
    } else {
1114
1406
        $rate = convert_rate ( $ratemax, $rate, 'RATE' , $ratename );
1115
1407
    }
1120
1412
        warning_message "Total RATE of classes ($devref->{guarantee}kbits) exceeds OUT-BANDWIDTH (${full}kbits)" if ( $devref->{guarantee} += $rate ) > $full;
1121
1413
    }
1122
1414
 
1123
 
    fatal_error "Invalid PRIO ($prio)" unless defined numeric_value $prio;
1124
 
 
1125
1415
    $tcref->{$classnumber} = { tos       => [] ,
1126
1416
                               rate      => $rate ,
1127
1417
                               umax      => $umax ,
1128
1418
                               dmax      => $dmax ,
1129
 
                               ceiling   => convert_rate( $ceilmax, $ceil, 'CEIL' , $ceilname ) ,
1130
 
                               priority  => $prio eq '-' ? 1 : $prio ,
 
1419
                               ceiling   => $ceil   = ( supplied $ceil   ? convert_rate( $ceilmax, $ceil,   'CEIL'  , $ceilname ) : 0 ),
 
1420
                               lsceil    => $lsceil = ( $lsceil          ? convert_rate( $ceilmax, $lsceil, 'LSCEIL', $ceilname ) : 0 ),
 
1421
                               priority  => $prio ,
1131
1422
                               mark      => $markval ,
 
1423
                               markprio  => $markprio ,
1132
1424
                               flow      => '' ,
1133
1425
                               pfifo     => 0,
1134
1426
                               occurs    => 1,
1140
1432
 
1141
1433
    $tcref = $tcref->{$classnumber};
1142
1434
 
1143
 
    fatal_error "RATE ($tcref->{rate}) exceeds CEIL ($tcref->{ceiling})" if $tcref->{rate} > $tcref->{ceiling};
 
1435
    fatal_error "RATE ($rate) exceeds CEIL ($ceil)" if $rate && $ceil && $rate > $ceil;
 
1436
 
 
1437
    my ( $red, %redopts ) = ( 0, ( avpkt => 1000 ) );
 
1438
    my ( $codel, %codelopts ) = ( 0, ( ) );
1144
1439
 
1145
1440
    unless ( $options eq '-' ) {
1146
1441
        for my $option ( split_list1 "\L$options", 'option' ) {
1147
 
            my $optval = $tosoptions{$option};
1148
 
 
1149
 
            $option = "tos=$optval" if $optval;
 
1442
            my $priority;
 
1443
            my $optval;
 
1444
 
 
1445
            ( $option, my $pri ) =  split /:/, $option, 2;
 
1446
 
 
1447
            if ( $option =~ /^tos=(.+)/ || ( $optval = $tosoptions{$option} ) ) {
 
1448
 
 
1449
                if ( supplied $pri ) {
 
1450
                    $priority = validate_filter_priority( $pri, 'mark' );
 
1451
                } else {
 
1452
                    fatal_error "Missing TOS priority" if $prio eq '-';
 
1453
                    $priority = ( $prio << 8 ) | 15;
 
1454
                    progress_message2 "   Priority of the $device $option filter is $priority";
 
1455
                }
 
1456
 
 
1457
                $option = "tos=$optval" if $optval;
 
1458
            } elsif ( supplied $pri ) {
 
1459
                $option = join ':', $option, $pri;
 
1460
            }
1150
1461
 
1151
1462
            if ( $option eq 'default' ) {
1152
1463
                fatal_error "Only one default class may be specified for device $device" if $devref->{default};
1153
1464
                fatal_error "The $option option is not valid with 'occurs" if $tcref->{occurs} > 1;
1154
1465
                $devref->{default} = $classnumber;
1155
 
            } elsif ( $option eq 'tcp-ack' ) {
 
1466
            } elsif ( $option =~ /tcp-ack(:(\d+|0x[0-0a-fA-F]))?$/ ) {
1156
1467
                fatal_error "The $option option is not valid with 'occurs" if $tcref->{occurs} > 1;
1157
 
                $tcref->{tcp_ack} = 1;
 
1468
                if ( $1 ) {
 
1469
                    $tcref->{tcp_ack} = validate_filter_priority( $2, 'tcp-ack' );
 
1470
                } else {
 
1471
                    fatal_error "Missing tcp-ack priority" if $prio eq '-';
 
1472
                    my $ackpri = $tcref->{tcp_ack} =  ( $prio << 8 ) | 10;
 
1473
                    progress_message2 "   Priority of the $device tcp-ack filter is $ackpri";
 
1474
                }
1158
1475
            } elsif ( $option =~ /^tos=0x[0-9a-f]{2}$/ ) {
1159
1476
                fatal_error "The $option option is not valid with 'occurs" if $tcref->{occurs} > 1;
1160
1477
                ( undef, $option ) = split /=/, $option;
1161
 
                push @{$tcref->{tos}}, "$option/0xff";
 
1478
                push @{$tcref->{tos}}, "$option/0xff:$priority";
1162
1479
            } elsif ( $option =~ /^tos=0x[0-9a-f]{2}\/0x[0-9a-f]{2}$/ ) {
1163
1480
                fatal_error "The $option option is not valid with 'occurs" if $tcref->{occurs} > 1;
1164
1481
                ( undef, $option ) = split /=/, $option;
1165
 
                push @{$tcref->{tos}}, $option;
 
1482
                push @{$tcref->{tos}}, "$option:$priority";
1166
1483
            } elsif ( $option =~ /^flow=(.*)$/ ) {
1167
1484
                fatal_error "The 'flow' option is not allowed with 'pfifo'" if $tcref->{pfifo};
 
1485
                fatal_error "The 'flow' option is not allowed with 'red'"   if $tcref->{red};
1168
1486
                $tcref->{flow} = process_flow $1;
1169
1487
            } elsif ( $option eq 'pfifo' ) {
1170
 
                fatal_error "The 'pfifo'' option is not allowed with 'flow='" if $tcref->{flow};
 
1488
                fatal_error "The 'pfifo' option is not allowed with 'flow='"      if $tcref->{flow};
 
1489
                fatal_error "The 'pfifo' option is not allowed with 'red='"       if $tcref->{red};
 
1490
                fatal_error "The 'pfifo' option is not allowed with 'fq_codel='"  if $tcref->{fq_codel};
1171
1491
                $tcref->{pfifo} = 1;
1172
1492
            } elsif ( $option =~ /^occurs=(\d+)$/ ) {
1173
1493
                my $val = $1;
1188
1508
                warning_message "limit ignored with pfifo queuing" if $tcref->{pfifo};
1189
1509
                fatal_error "Invalid limit ($1)" if $1 < 3 || $1 > 128;
1190
1510
                $tcref->{limit} = $1;
 
1511
            } elsif ( $option =~ s/^red=// ) {
 
1512
                fatal_error "The 'red=' option is not allowed with 'flow='"       if $tcref->{flow};
 
1513
                fatal_error "The 'red=' option is not allowed with 'pfifo'"       if $tcref->{pfifo};
 
1514
                fatal_error "The 'pfifo' option is not allowed with 'fq_codel='"  if $tcref->{fq_codel};
 
1515
                $tcref->{red} = 1;
 
1516
                my $opttype;
 
1517
 
 
1518
                for my $redopt ( split_list( $option , q('red' option list) ) ) {
 
1519
                    #
 
1520
                    #                            $2  ----------------------
 
1521
                    #              $1  ------       | $3 -------           |
 
1522
                    #                 |      |      |   |       |          |
 
1523
                    if ( $redopt =~ /^([a-z]+) (?:= (   ([01]?\.)?(\d{1,8})) )?$/x ) {
 
1524
                        fatal_error "Invalid RED option ($1)" unless $opttype = $validredoptions{$1};
 
1525
                        if ( $2 ) {
 
1526
                            #
 
1527
                            # '=<value>' supplied
 
1528
                            #
 
1529
                            fatal_error "The $1 option does not take a value" if $opttype == RED_NONE;
 
1530
                            if ( $3 ) {
 
1531
                                #
 
1532
                                # fractional value
 
1533
                                #
 
1534
                                fatal_error "The $1 option requires an integer value"  if $opttype == RED_INTEGER;
 
1535
                                fatal_error "The value of $1 must be <= 1" if $2 > 1;
 
1536
                            } else {
 
1537
                                #
 
1538
                                # Integer value
 
1539
                                #
 
1540
                                fatal_error "The $1 option requires a value 0 <= value <= 1" if $opttype == RED_FLOAT;
 
1541
                            }
 
1542
                        } else {
 
1543
                            #
 
1544
                            # No value supplied
 
1545
                            #
 
1546
                            fatal_error "The $1 option requires a value" unless $opttype == RED_NONE;
 
1547
                        }
 
1548
 
 
1549
                        $redopts{$1} = $2;
 
1550
                    } else {
 
1551
                        fatal_error "Invalid RED option specification ($redopt)";
 
1552
                    }
 
1553
                }
 
1554
 
 
1555
                for ( qw/ limit min max avpkt burst probability / ) {
 
1556
                    fatal_error "The $_ 'red' option is required" unless $redopts{$_};
 
1557
                }
 
1558
 
 
1559
                fatal_error "The 'max' red option must be at least 2 * 'min'"   unless $redopts{max}   >= 2 * $redopts{min};
 
1560
                fatal_error "The 'limit' red option must be at least 2 * 'max'" unless $redopts{limit} >= 2 * $redopts{min};
 
1561
                $redopts{ecn} = 1 if exists $redopts{ecn};
 
1562
                $tcref->{redopts} = \%redopts;
 
1563
            } elsif ( $option =~ /^fq_codel(?:=.+)?$/ ) {
 
1564
                fatal_error "The 'fq_codel' option is not allowed with 'red='"       if $tcref->{red};
 
1565
                fatal_error "The 'fq_codel' option is not allowed with 'pfifo'"      if $tcref->{pfifo};
 
1566
                $tcref->{fq_codel} = 1;
 
1567
                my $opttype;
 
1568
 
 
1569
                $option =~ s/fq_codel=?//;
 
1570
 
 
1571
                for my $codelopt ( split_list( $option , q('fq_codel' option list) ) ) {
 
1572
                    #
 
1573
                    #              $1  ------      $2 --------------
 
1574
                    #                 |      |        |    $3 ---- | 
 
1575
                    #                 |      |        |       |  | |
 
1576
                    if ( $codelopt =~ /^([a-z]+) (?:= ((?:\d+)(ms)?))?$/x )
 
1577
                            {
 
1578
                        fatal_error "Invalid CODEL option ($1)" unless $opttype = $validcodeloptions{$1};
 
1579
                        if ( $2 ) {
 
1580
                            #
 
1581
                            # '=<value>' supplied
 
1582
                            #
 
1583
                            fatal_error "The $1 option does not take a value" if $opttype == CODEL_NONE;
 
1584
                            if ( $3 ) {
 
1585
                                #
 
1586
                                # Rate
 
1587
                                #
 
1588
                                fatal_error "The $1 option requires an integer value"  if $opttype == CODEL_INTEGER;
 
1589
                            } else {
 
1590
                                #
 
1591
                                # Interval value
 
1592
                                #
 
1593
                                fatal_error "The $1 option requires an interval value" if $opttype == CODEL_INTERVAL;
 
1594
                            }
 
1595
                        } else {
 
1596
                            #
 
1597
                            # No value supplied
 
1598
                            #
 
1599
                            fatal_error "The $1 option requires a value" unless $opttype == CODEL_NONE;
 
1600
                        }
 
1601
 
 
1602
                        $codelopts{$1} = $2;
 
1603
                    } else {
 
1604
                        fatal_error "Invalid fq_codel option specification ($codelopt)";
 
1605
                    }
 
1606
                }
 
1607
 
 
1608
                if ( exists $codelopts{ecn} ) {
 
1609
                    fatal_error "The 'ecn' and 'noecn' fq_codel options are mutually exclusive" if exists $codelopts{noecn};
 
1610
                    $codelopts{ecn} = 1;
 
1611
                } elsif ( exists $codelopts{noecn} ) {
 
1612
                    $codelopts{noecn} = 1;
 
1613
                } else {
 
1614
                    $codelopts{ecn} = 1;
 
1615
                }
 
1616
                    
 
1617
                $tcref->{codelopts} = \%codelopts;
1191
1618
            } else {
1192
1619
                fatal_error "Unknown option ($option)";
1193
1620
            }
1195
1622
    }
1196
1623
 
1197
1624
    unless ( $devref->{classify} || $occurs > 1 ) {
1198
 
        if ( $mark ne '-' ) {
1199
 
            fatal_error "Missing MARK" if $mark eq '-';
1200
 
            warning_message "Class NUMBER ignored -- INTERFACE $device does not have the 'classify' option"     if $devclass =~ /:/;
1201
 
        }
 
1625
        fatal_error "Missing MARK" if $mark eq '-';
1202
1626
    }
1203
1627
 
1204
1628
    $tcref->{flow}  = $devref->{flow}  unless $tcref->{flow};
1209
1633
    while ( --$occurs ) {
1210
1634
        fatal_error "Duplicate class number ($classnumber)" if $tcclasses{$device}{++$classnumber};
1211
1635
 
1212
 
        $tcclasses{$device}{$classnumber} =  { tos      => [] ,
1213
 
                                               rate     => $tcref->{rate} ,
1214
 
                                               ceiling  => $tcref->{ceiling} ,
1215
 
                                               priority => $tcref->{priority} ,
1216
 
                                               mark     => 0 ,
1217
 
                                               flow     => $tcref->{flow} ,
1218
 
                                               pfifo    => $tcref->{pfifo},
1219
 
                                               occurs   => 0,
1220
 
                                               parent   => $parentclass,
1221
 
                                               limit    => $tcref->{limit},
 
1636
        $tcclasses{$device}{$classnumber} =  { tos       => [] ,
 
1637
                                               rate      => $tcref->{rate} ,
 
1638
                                               ceiling   => $tcref->{ceiling} ,
 
1639
                                               priority  => $tcref->{priority} ,
 
1640
                                               mark      => 0 ,
 
1641
                                               markprio  => $markprio ,
 
1642
                                               flow      => $tcref->{flow} ,
 
1643
                                               pfifo     => $tcref->{pfifo},
 
1644
                                               occurs    => 0,
 
1645
                                               parent    => $parentclass,
 
1646
                                               limit     => $tcref->{limit},
 
1647
                                               red       => $tcref->{red},
 
1648
                                               redopts   => $tcref->{redopts},
 
1649
                                               fq_codel  => $tcref->{fq_codel},
 
1650
                                               codelopts => $tcref->{codelopts},
1222
1651
                                             };
1223
1652
        push @tcclasses, "$device:$classnumber";
1224
1653
    };
1231
1660
#
1232
1661
# Process a record from the tcfilters file
1233
1662
#
1234
 
sub process_tc_filter() {
1235
 
 
1236
 
    my ( $devclass, $source, $dest , $proto, $portlist , $sportlist, $tos, $length ) = split_line 'tcfilters file', { class => 0, source => 1, dest => 2, proto => 3, dport => 4, sport => 5, tos => 6, length => 7 };
1237
 
 
1238
 
    fatal_error 'CLASS must be specified' if $devclass eq '-';
 
1663
sub process_tc_filter1( $$$$$$$$$ ) {
 
1664
 
 
1665
    my ( $devclass, $source, $dest , $proto, $portlist , $sportlist, $tos, $length, $priority ) = @_;
1239
1666
 
1240
1667
    my ($device, $class, $rest ) = split /:/, $devclass, 3;
1241
1668
 
1243
1670
 
1244
1671
    fatal_error "Invalid INTERFACE:CLASS ($devclass)" if defined $rest || ! ($device && $class );
1245
1672
 
1246
 
    my ( $ip, $ip32, $prio , $lo ) = $family == F_IPV4 ? ('ip', 'ip', 10, 2 ) : ('ipv6', 'ip6', 11 , 4 );
 
1673
    my ( $ip, $ip32, $lo ) = $family == F_IPV4 ? ('ip', 'ip', 2 ) : ('ipv6', 'ip6', 4 );
1247
1674
 
1248
1675
    my $devref;
1249
1676
 
1253
1680
        ( $device , $devref ) = dev_by_number( $device );
1254
1681
    }
1255
1682
 
 
1683
    my ( $prio, $filterpri ) = ( undef, $devref->{filterpri} );
 
1684
 
 
1685
    if ( $priority eq '-' ) {
 
1686
        $prio = ++$filterpri;
 
1687
        fatal_error "Filter priority overflow" if $prio > 65535;
 
1688
    } else {
 
1689
        $prio = validate_filter_priority( $priority, 'filter' );
 
1690
        $filterpri = $prio if $prio > $filterpri;
 
1691
    }
 
1692
 
 
1693
    $devref->{filterpri} = $filterpri;
 
1694
 
1256
1695
    my $devnum = in_hexp $devref->{number};
1257
1696
 
1258
1697
    my $tcref = $tcclasses{$device};
1494
1933
 
1495
1934
}
1496
1935
 
 
1936
sub process_tc_filter() {
 
1937
 
 
1938
    my ( $devclass, $source, $dest , $protos, $portlist , $sportlist, $tos, $length, $priority )
 
1939
        = split_line 'tcfilters file', { class => 0, source => 1, dest => 2, proto => 3, dport => 4, sport => 5, tos => 6, length => 7 , priority => 8 };
 
1940
 
 
1941
    fatal_error 'CLASS must be specified' if $devclass eq '-';
 
1942
 
 
1943
    for my $proto ( split_list $protos, 'Protocol' ) {
 
1944
        process_tc_filter1( $devclass, $source, $dest , $proto, $portlist , $sportlist, $tos, $length, $priority );
 
1945
    }
 
1946
}
 
1947
 
1497
1948
#
1498
1949
# Process the tcfilter file storing the compiled filters in the %tcdevices table
1499
1950
#
1534
1985
#
1535
1986
# Process a tcpri record
1536
1987
#
1537
 
sub process_tc_priority() {
1538
 
    my ( $band, $proto, $ports , $address, $interface, $helper ) = split_line1 'tcpri', { band => 0, proto => 1, port => 2, address => 3, interface => 4, helper => 5 };
1539
 
 
1540
 
    fatal_error 'BAND must be specified' if $band eq '-';
1541
 
 
1542
 
    if ( $band eq 'COMMENT' ) {
1543
 
        process_comment;
1544
 
        return;
1545
 
    }
1546
 
 
1547
 
    fatal_error "Invalid tcpri entry" if ( $proto     eq '-' &&
1548
 
                                           $ports     eq '-' &&
1549
 
                                           $address   eq '-' &&
1550
 
                                           $interface eq '-' &&
1551
 
                                           $helper    eq '-' );
1552
 
 
 
1988
sub process_tc_priority1( $$$$$$ ) {
 
1989
    my ( $band, $proto, $ports , $address, $interface, $helper ) = @_;
1553
1990
 
1554
1991
    my $val = numeric_value $band;
1555
1992
 
1597
2034
    }
1598
2035
}
1599
2036
 
 
2037
sub process_tc_priority() {
 
2038
    my ( $band, $protos, $ports , $address, $interface, $helper ) = split_line1 'tcpri', { band => 0, proto => 1, port => 2, address => 3, interface => 4, helper => 5 };
 
2039
 
 
2040
    fatal_error 'BAND must be specified' if $band eq '-';
 
2041
 
 
2042
    fatal_error "Invalid tcpri entry" if ( $protos    eq '-' &&
 
2043
                                           $ports     eq '-' &&
 
2044
                                           $address   eq '-' &&
 
2045
                                           $interface eq '-' &&
 
2046
                                           $helper    eq '-' );
 
2047
 
 
2048
    my $val = numeric_value $band;
 
2049
 
 
2050
    fatal_error "Invalid PRIORITY ($band)" unless $val && $val <= 3;
 
2051
 
 
2052
    for my $proto ( split_list $protos, 'Protocol' ) {
 
2053
        process_tc_priority1( $band, $proto, $ports , $address, $interface, $helper );
 
2054
    }
 
2055
}
 
2056
 
1600
2057
#
1601
2058
# Process tcinterfaces
1602
2059
#
1615
2072
#
1616
2073
sub process_tcpri() {
1617
2074
    my $fn  = find_file 'tcinterfaces';
1618
 
    my $fn1 = open_file 'tcpri';
 
2075
    my $fn1 = open_file 'tcpri', 1,1;
1619
2076
 
1620
2077
    if ( $fn1 ) {
1621
2078
        first_entry
1626
2083
 
1627
2084
        process_tc_priority while read_a_line( NORMAL_READ );
1628
2085
 
1629
 
        clear_comment;
1630
 
 
1631
2086
        if ( $ipp2p ) {
1632
2087
            insert_irule( $mangle_table->{tcpost} ,
1633
2088
                          j => 'CONNMARK --restore-mark --ctmask ' . in_hex( $globals{TC_MASK} ) ,
1684
2139
        my $defmark = in_hexp ( $devref->{default} || 0 );
1685
2140
        my $devnum  = in_hexp $devref->{number};
1686
2141
        my $r2q     = int calculate_r2q $devref->{out_bandwidth};
 
2142
        my $qdisc   = $devref->{qdisc};
1687
2143
 
1688
2144
        fatal_error "No default class defined for device $devname" unless defined $devref->{default};
1689
2145
 
1691
2147
 
1692
2148
        unless ( $config{TC_ENABLED} eq 'Shared' ) {
1693
2149
 
1694
 
            my $dev = chain_base( $device );
 
2150
            my $dev = var_base( $device );
1695
2151
 
1696
2152
            emit( '',
1697
2153
                  '#',
1706
2162
            push_indent;
1707
2163
 
1708
2164
            emit ( "qt \$TC qdisc del dev $device root",
1709
 
                   "qt \$TC qdisc del dev $device ingress",
1710
 
                   "${dev}_mtu=\$(get_device_mtu $device)",
 
2165
                   "qt \$TC qdisc del dev $device ingress" );
 
2166
 
 
2167
            emit ( "${dev}_mtu=\$(get_device_mtu $device)",
1711
2168
                   "${dev}_mtu1=\$(get_device_mtu1 $device)"
1712
 
                 );
1713
 
 
1714
 
            if ( $devref->{qdisc} eq 'htb' ) {
1715
 
                emit ( "run_tc qdisc add dev $device root handle $devnum: htb default $defmark r2q $r2q" ,
 
2169
                 ) if $qdisc eq 'htb';
 
2170
 
 
2171
            my $stab;
 
2172
 
 
2173
            if ( $devref->{linklayer} ) {
 
2174
                $stab =  "stab linklayer $devref->{linklayer} overhead $devref->{overhead} ";
 
2175
                $stab .= "mtu $devref->{mtu} "     if $devref->{mtu};
 
2176
                $stab .= "mpu $devref->{mpu} "     if $devref->{mpu};
 
2177
                $stab .= "tsize $devref->{tsize} " if $devref->{tsize};
 
2178
            } else {
 
2179
                $stab = '';
 
2180
            }
 
2181
 
 
2182
            if ( $qdisc eq 'htb' ) {
 
2183
                emit ( "run_tc qdisc add dev $device ${stab}root handle $devnum: htb default $defmark r2q $r2q" ,
1716
2184
                       "run_tc class add dev $device parent $devnum: classid $devnum:1 htb rate $devref->{out_bandwidth} \$${dev}_mtu1" );
1717
2185
            } else {
1718
 
                emit ( "run_tc qdisc add dev $device root handle $devnum: hfsc default $defmark" ,
 
2186
                emit ( "run_tc qdisc add dev $device ${stab}root handle $devnum: hfsc default $defmark" ,
1719
2187
                       "run_tc class add dev $device parent $devnum: classid $devnum:1 hfsc sc rate $devref->{out_bandwidth} ul rate $devref->{out_bandwidth}" );
1720
2188
            }
1721
2189
 
1739
2207
            handle_in_bandwidth( $device, $devref->{in_bandwidth} );
1740
2208
 
1741
2209
            for my $rdev ( @{$devref->{redirected}} ) {
1742
 
                my $phyrdev = get_physical( $rdev );
 
2210
                my $phyrdev = physical_name( $rdev );
1743
2211
                emit ( "run_tc qdisc add dev $phyrdev handle ffff: ingress" );
1744
2212
                emit( "run_tc filter add dev $phyrdev parent ffff: protocol all u32 match u32 0 0 action mirred egress redirect dev $device > /dev/null" );
1745
2213
            }
1762
2230
                my $mark     = $tcref->{mark};
1763
2231
                my $devicenumber  = in_hexp $devref->{number};
1764
2232
                my $classid  = join( ':', $devicenumber, $classnum);
1765
 
                my $rate     = "$tcref->{rate}kbit";
1766
 
                my $quantum  = calculate_quantum $rate, calculate_r2q( $devref->{out_bandwidth} );
 
2233
                my $rawrate  = $tcref->{rate};
 
2234
                my $rate     = "${rawrate}kbit";
 
2235
                my $lsceil   = $tcref->{lsceil};
 
2236
                my $quantum;
1767
2237
 
1768
2238
                $classids{$classid}=$devname;
1769
2239
 
1770
 
                my $priority = $tcref->{priority} << 8;
1771
2240
                my $parent   = in_hexp $tcref->{parent};
1772
2241
 
1773
 
                emit ( "[ \$${dev}_mtu -gt $quantum ] && quantum=\$${dev}_mtu || quantum=$quantum" );
1774
 
 
1775
2242
                if ( $devref->{qdisc} eq 'htb' ) {
 
2243
                    $quantum  = calculate_quantum $rate, calculate_r2q( $devref->{out_bandwidth} );
 
2244
                    emit ( "[ \$${dev}_mtu -gt $quantum ] && quantum=\$${dev}_mtu || quantum=$quantum" );
1776
2245
                    emit ( "run_tc class add dev $device parent $devicenumber:$parent classid $classid htb rate $rate ceil $tcref->{ceiling}kbit prio $tcref->{priority} \$${dev}_mtu1 quantum \$quantum" );
1777
2246
                } else {
1778
2247
                    my $dmax = $tcref->{dmax};
 
2248
                    my $rule = "run_tc class add dev $device parent $devicenumber:$parent classid $classid hfsc";
1779
2249
 
1780
2250
                    if ( $dmax ) {
1781
2251
                        my $umax = $tcref->{umax} ? "$tcref->{umax}b" : "\${${dev}_mtu}b";
1782
 
                        emit ( "run_tc class add dev $device parent $devicenumber:$parent classid $classid hfsc sc umax $umax dmax ${dmax}ms rate $rate ul rate $tcref->{ceiling}kbit" );
 
2252
                        $rule .= " sc umax $umax dmax ${dmax}ms";
 
2253
                        $rule .= " rate $rate" if $rawrate;
1783
2254
                    } else {
1784
 
                        emit ( "run_tc class add dev $device parent $devicenumber:$parent classid $classid hfsc sc rate $rate ul rate $tcref->{ceiling}kbit" );
 
2255
                        $rule .= " sc rate $rate" if $rawrate;
1785
2256
                    }
 
2257
 
 
2258
                    $rule .= " ls rate ${lsceil}kbit" if $lsceil;
 
2259
                    $rule .= " ul rate $tcref->{ceiling}kbit" if $tcref->{ceiling};
 
2260
 
 
2261
                    emit $rule;
1786
2262
                }
1787
2263
 
1788
 
                if ( $tcref->{leaf} && ! $tcref->{pfifo} ) {
1789
 
                    1 while $devnums[++$sfq];
1790
 
 
1791
 
                    $sfqinhex = in_hexp( $sfq);
1792
 
                    if ( $devref->{qdisc} eq 'htb' ) {
1793
 
                        emit( "run_tc qdisc add dev $device parent $classid handle $sfqinhex: sfq quantum \$quantum limit $tcref->{limit} perturb 10" );
1794
 
                    } else {
1795
 
                        emit( "run_tc qdisc add dev $device parent $classid handle $sfqinhex: sfq limit $tcref->{limit} perturb 10" );
 
2264
                if ( $tcref->{leaf} ) {
 
2265
                    if ( $tcref->{red} ) {
 
2266
                        1 while $devnums[++$sfq];
 
2267
                        $sfqinhex = in_hexp( $sfq);
 
2268
 
 
2269
                        my ( $options, $redopts ) = ( '', $tcref->{redopts} );
 
2270
 
 
2271
                        while ( my ( $option, $type ) = each %validredoptions ) {
 
2272
                            if ( my $value = $redopts->{$option} ) {
 
2273
                                if ( $type == RED_NONE ) {
 
2274
                                    $options = join( ' ', $options, $option ) if $value;
 
2275
                                } else {
 
2276
                                    $options = join( ' ', $options, $option, $value );
 
2277
                                }
 
2278
                            }
 
2279
                        }
 
2280
 
 
2281
                        emit( "run_tc qdisc add dev $device parent $classid handle $sfqinhex: red${options}" );
 
2282
                    } elsif ( $tcref->{fq_codel} ) {
 
2283
                        1 while $devnums[++$sfq];
 
2284
                        $sfqinhex = in_hexp( $sfq);
 
2285
 
 
2286
                        my ( $options, $codelopts ) = ( '', $tcref->{codelopts} );
 
2287
 
 
2288
                        while ( my ( $option, $type ) = each %validcodeloptions ) {
 
2289
                            if ( my $value = $codelopts->{$option} ) {
 
2290
                                if ( $type == CODEL_NONE ) {
 
2291
                                    $options = join( ' ', $options, $option );
 
2292
                                } else {
 
2293
                                    $options = join( ' ', $options, $option, $value );
 
2294
                                }
 
2295
                            }
 
2296
                        }
 
2297
 
 
2298
                        emit( "run_tc qdisc add dev $device parent $classid handle $sfqinhex: fq_codel${options}" );
 
2299
                        
 
2300
                    } elsif ( ! $tcref->{pfifo} ) {
 
2301
                        1 while $devnums[++$sfq];
 
2302
 
 
2303
                        $sfqinhex = in_hexp( $sfq);
 
2304
                        if ( $qdisc eq 'htb' ) {
 
2305
                            emit( "run_tc qdisc add dev $device parent $classid handle $sfqinhex: sfq quantum \$quantum limit $tcref->{limit} perturb 10" );
 
2306
                        } else {
 
2307
                            emit( "run_tc qdisc add dev $device parent $classid handle $sfqinhex: sfq limit $tcref->{limit} perturb 10" );
 
2308
                        }
1796
2309
                    }
1797
2310
                }
1798
2311
                #
1799
2312
                # add filters
1800
2313
                #
1801
2314
                unless ( $mark eq '-' ) {
1802
 
                    emit "run_tc filter add dev $device protocol all parent $devicenumber:0 prio " . ( $priority | 20 ) . " handle $mark fw classid $classid" if $tcref->{occurs} == 1;
 
2315
                    emit "run_tc filter add dev $device protocol all parent $devicenumber:0 prio $tcref->{markprio} handle $mark fw classid $classid" if $tcref->{occurs} == 1;
1803
2316
                }
1804
2317
 
1805
2318
                emit "run_tc filter add dev $device protocol all prio 1 parent $sfqinhex: handle $classnum flow hash keys $tcref->{flow} divisor 1024" if $tcref->{flow};
1806
2319
                #
1807
2320
                # options
1808
2321
                #
1809
 
                emit( "run_tc filter add dev $device parent $devicenumber:0 protocol ip prio " . ( $priority | 10 ) . ' u32' .
 
2322
                emit( "run_tc filter add dev $device parent $devicenumber:0 protocol ip prio $tcref->{tcp_ack} u32" .
1810
2323
                      "\\\n    match ip protocol 6 0xff" .
1811
2324
                      "\\\n    match u8 0x05 0x0f at 0" .
1812
2325
                      "\\\n    match u16 0x0000 0xffc0 at 2" .
1813
2326
                      "\\\n    match u8 0x10 0xff at 33 flowid $classid" ) if $tcref->{tcp_ack};
1814
2327
 
1815
2328
                for my $tospair ( @{$tcref->{tos}} ) {
 
2329
                    ( $tospair, my $priority ) = split /:/, $tospair;
1816
2330
                    my ( $tos, $mask ) = split q(/), $tospair;
1817
 
                    emit "run_tc filter add dev $device parent $devicenumber:0 protocol ip prio " . ( $priority | 10 ) . " u32 match ip tos $tos $mask flowid $classid";
 
2331
                    emit "run_tc filter add dev $device parent $devicenumber:0 protocol ip prio $priority u32 match ip tos $tos $mask flowid $classid";
1818
2332
                }
1819
2333
 
1820
2334
                save_progress_message_short qq("   TC Class $classid defined.");
1863
2377
}
1864
2378
 
1865
2379
#
1866
 
# Validate the TC configuration storing basic information in %tcdevices and %tcdevices
 
2380
# Validate the TC configuration storing basic information in %tcdevices and %tcclasses (complex TC only)
1867
2381
#
1868
2382
sub process_tc() {
1869
2383
    if ( $config{TC_ENABLED} eq 'Internal' || $config{TC_ENABLED} eq 'Shared' ) {
1889
2403
 
1890
2404
    for my $device ( @tcdevices ) {
1891
2405
        my $interfaceref = known_interface( $device );
1892
 
        my $dev          = chain_base( $interfaceref ? $interfaceref->{physical} : $device );
 
2406
        my $dev          = var_base( $interfaceref ? $interfaceref->{physical} : $device );
1893
2407
 
1894
2408
        emit "setup_${dev}_tc";
1895
2409
    }
1898
2412
#
1899
2413
# Process a record in the secmarks file
1900
2414
#
1901
 
sub process_secmark_rule() {
1902
 
    my ( $secmark, $chainin, $source, $dest, $proto, $dport, $sport, $user, $mark ) =
1903
 
        split_line1( 'Secmarks file' , { secmark => 0, chain => 1, source => 2, dest => 3, proto => 4, dport => 5, sport => 6, user => 7, mark => 8 } );
1904
 
 
1905
 
    fatal_error 'SECMARK must be specified' if $secmark eq '-';
1906
 
 
1907
 
    if ( $secmark eq 'COMMENT' ) {
1908
 
        process_comment;
1909
 
        return;
1910
 
    }
 
2415
sub process_secmark_rule1( $$$$$$$$$ ) {
 
2416
    my ( $secmark, $chainin, $source, $dest, $proto, $dport, $sport, $user, $mark ) = @_;
1911
2417
 
1912
2418
    my %chns = ( T => 'tcpost'  ,
1913
2419
                 P => 'tcpre'   ,
1915
2421
                 I => 'tcin'    ,
1916
2422
                 O => 'tcout'   , );
1917
2423
 
1918
 
    my %state = ( N =>  'NEW' ,
1919
 
                  I => 'INVALID',
1920
 
                  NI => 'NEW,INVALID',
1921
 
                  E =>  'ESTABLISHED' ,
1922
 
                  ER => 'ESTABLISHED,RELATED',
 
2424
    my %state = ( N   => 'NEW' ,
 
2425
                  I   => 'INVALID',
 
2426
                  U   => 'UNTRACKED',
 
2427
                  IU  => 'INVALID,UNTRACKED',
 
2428
                  NI  => 'NEW,INVALID',
 
2429
                  NU  => 'NEW,UNTRACKED',
 
2430
                  NIU => 'NEW,INVALID,UNTRACKED',
 
2431
                  E   => 'ESTABLISHED' ,
 
2432
                  ER  => 'ESTABLISHED,RELATED',
1923
2433
                );
1924
2434
 
1925
2435
    my ( $chain , $state, $rest) = split ':', $chainin , 3;
1947
2457
 
1948
2458
    expand_rule( ensure_mangle_chain( $chain1 ) ,
1949
2459
                 $restrictions{$chain1} ,
 
2460
                 '' ,
1950
2461
                 $state .
1951
2462
                 do_proto( $proto, $dport, $sport ) .
1952
2463
                 do_user( $user ) .
1964
2475
}
1965
2476
 
1966
2477
#
 
2478
# Process a record in the secmarks file
 
2479
#
 
2480
sub process_secmark_rule() {
 
2481
    my ( $secmark, $chainin, $source, $dest, $protos, $dport, $sport, $user, $mark ) =
 
2482
        split_line1( 'Secmarks file' , { secmark => 0, chain => 1, source => 2, dest => 3, proto => 4, dport => 5, sport => 6, user => 7, mark => 8 } );
 
2483
 
 
2484
    fatal_error 'SECMARK must be specified' if $secmark eq '-';
 
2485
 
 
2486
    for my $proto ( split_list( $protos, 'Protocol' ) ) {
 
2487
        process_secmark_rule1( $secmark, $chainin, $source, $dest, $proto, $dport, $sport, $user, $mark );
 
2488
    }
 
2489
}
 
2490
 
 
2491
#
1967
2492
# Process the tcrules file and setup traffic shaping
1968
2493
#
1969
2494
sub setup_tc() {
1997
2522
        add_ijump $mangle_table->{OUTPUT} ,     j => 'tcout', @mark_part;
1998
2523
 
1999
2524
        if ( have_capability( 'MANGLE_FORWARD' ) ) {
2000
 
            my $mask = have_capability 'EXMARK' ? have_capability 'FWMARK_RT_MASK' ? '/' . in_hex $globals{PROVIDER_MASK} : '' : '';
 
2525
            my $mask = have_capability( 'EXMARK' ) ? have_capability( 'FWMARK_RT_MASK' ) ? '/' . in_hex $globals{PROVIDER_MASK} : '' : '';
2001
2526
 
2002
2527
            add_ijump $mangle_table->{FORWARD},      j => "MARK --set-mark 0${mask}" if $config{FORWARD_CLEAR_MARK};
2003
2528
            add_ijump $mangle_table->{FORWARD} ,     j => 'tcfor';
2011
2536
        append_file $globals{TC_SCRIPT};
2012
2537
    } else {
2013
2538
        process_tcpri if $config{TC_ENABLED} eq 'Simple';
2014
 
        setup_traffic_shaping unless $config{TC_ENABLED} eq 'Shared';
 
2539
        setup_traffic_shaping if @tcdevices && $config{TC_ENABLED} ne 'Shared';
2015
2540
    }
2016
2541
 
2017
 
    if ( $config{TC_ENABLED} ) {
2018
 
        our  @tccmd = ( { match     => sub ( $ ) { $_[0] eq 'SAVE' } ,
2019
 
                          target    => 'CONNMARK --save-mark --mask' ,
2020
 
                          mark      => $config{TC_EXPERT} ? HIGHMARK : SMALLMARK,
2021
 
                          mask      => in_hex( $globals{TC_MASK} ) ,
2022
 
                          connmark  => 1
2023
 
                        } ,
2024
 
                        { match     => sub ( $ ) { $_[0] eq 'RESTORE' },
2025
 
                          target    => 'CONNMARK --restore-mark --mask' ,
2026
 
                          mark      => $config{TC_EXPERT} ? HIGHMARK : SMALLMARK ,
2027
 
                          mask      => in_hex( $globals{TC_MASK} ) ,
2028
 
                          connmark  => 1
2029
 
                        } ,
2030
 
                        { match     => sub ( $ ) { $_[0] eq 'CONTINUE' },
2031
 
                          target    => 'RETURN' ,
2032
 
                          mark      => NOMARK ,
2033
 
                          mask      => '' ,
2034
 
                          connmark  => 0
2035
 
                        } ,
2036
 
                        { match     => sub ( $ ) { $_[0] eq 'SAME' },
2037
 
                          target    => 'sticky' ,
2038
 
                          mark      => NOMARK ,
2039
 
                          mask      => '' ,
2040
 
                          connmark  => 0
2041
 
                        } ,
2042
 
                        { match     => sub ( $ ) { $_[0] =~ /^IPMARK/ },
2043
 
                          target    => 'IPMARK' ,
2044
 
                          mark      => NOMARK,
2045
 
                          mask      => '',
2046
 
                          connmark  => 0
2047
 
                        } ,
2048
 
                        { match     => sub ( $ ) { $_[0] =~ '\|.*'} ,
2049
 
                          target    => 'MARK --or-mark' ,
2050
 
                          mark      => HIGHMARK ,
2051
 
                          mask      => '' } ,
2052
 
                        { match     => sub ( $ ) { $_[0] =~ '&.*' },
2053
 
                          target    => 'MARK --and-mark' ,
2054
 
                          mark      => HIGHMARK ,
2055
 
                          mask      => '' ,
2056
 
                          connmark  => 0
2057
 
                        } ,
2058
 
                        { match     => sub ( $ ) { $_[0] =~ /^TPROXY/ },
2059
 
                          target    => 'TPROXY',
2060
 
                          mark      => HIGHMARK,
2061
 
                          mask      => '',
2062
 
                          connmark  => '' },
2063
 
                        { match     => sub( $ ) { $_[0] =~ /^DIVERT/ },
2064
 
                          target    => 'DIVERT',
2065
 
                          mark      => HIGHMARK,
2066
 
                          mask      => '',
2067
 
                          connmark  => '' },
2068
 
                        { match     => sub( $ ) { $_[0] =~ /^TTL/ },
2069
 
                          target    => 'TTL',
2070
 
                          mark      => NOMARK,
2071
 
                          mask      => '',
2072
 
                          connmark  => 0
2073
 
                        },
2074
 
                        { match     => sub( $ ) { $_[0] =~ /^HL/ },
2075
 
                          target    => 'HL',
2076
 
                          mark      => NOMARK,
2077
 
                          mask      => '',
2078
 
                          connmark  => 0
2079
 
                        },
2080
 
                        { match     => sub( $ ) { $_[0] =~ /^IMQ\(\d+\)$/ },
2081
 
                          target    => 'IMQ',
2082
 
                          mark      => NOMARK,
2083
 
                          mask      => '',
2084
 
                          connmark  => 0
2085
 
                        },
2086
 
                        { match     => sub( $ ) { $_[0] =~ /^DSCP\(\w+\)$/ },
2087
 
                          target    => 'DSCP',
2088
 
                          mark      => NOMARK,
2089
 
                          mask      => '',
2090
 
                          connmark  => 0
2091
 
                        },
2092
 
                        { match     => sub( $ ) { $_[0] =~ /^TOS\(.+\)$/ },
2093
 
                          target    => 'TOS',
2094
 
                          mark      => NOMARK,
2095
 
                          mask      => '',
2096
 
                          connmark  => 0
2097
 
                        },
2098
 
                      );
2099
 
 
2100
 
        if ( my $fn = open_file 'tcrules' ) {
2101
 
 
2102
 
            our $format = 1;
 
2542
    if ( $config{MANGLE_ENABLED} ) {
 
2543
 
 
2544
        if ( my $fn = open_file( 'tcrules' , 2, 1 ) ) {
2103
2545
 
2104
2546
            first_entry "$doing $fn...";
2105
2547
 
2106
2548
            process_tc_rule while read_a_line( NORMAL_READ );
2107
2549
 
2108
 
            clear_comment;
2109
 
 
2110
2550
        }
2111
 
    }
2112
2551
 
2113
 
    if ( $config{MANGLE_ENABLED} ) {
2114
 
        if ( my $fn = open_file 'secmarks' ) {
 
2552
        if ( my $fn = open_file( 'secmarks', 1, 1 ) ) {
2115
2553
 
2116
2554
            first_entry "$doing $fn...";
2117
2555
 
2118
2556
            process_secmark_rule while read_a_line( NORMAL_READ );
2119
2557
 
2120
 
            clear_comment;
2121
2558
        }
2122
2559
 
2123
2560
        handle_stickiness( $sticky );