File Coverage

lib/Net/DNS/SPF/Expander.pm
Criterion Covered Total %
statement 273 309 88.3
branch 39 56 69.6
condition 5 10 50.0
subroutine 36 37 97.3
pod 2 2 100.0
total 355 414 85.7


line stmt bran cond sub pod time code
1             package Net::DNS::SPF::Expander;
2             $Net::DNS::SPF::Expander::VERSION = '0.021';
3 4     4   7396 use Moo;
  4         40762  
  4         18  
4 4     4   6303 use MooX::Options;
  4         16557  
  4         18  
5 4     4   397850 use Types::Standard qw/Str HashRef ArrayRef Maybe Int InstanceOf RegexpRef/;
  4         258198  
  4         58  
6 4     4   6773 use Net::DNS::ZoneFile;
  4         94883  
  4         243  
7 4     4   1680 use Net::DNS::Resolver;
  4         191529  
  4         505  
8 4     4   3597 use Path::Tiny;
  4         40841  
  4         327  
9 4     4   2124 use List::AllUtils qw(sum any part first uniq);
  4         36875  
  4         363  
10 4     4   30 use Scalar::Util ();
  4         11  
  4         14934  
11              
12             # ABSTRACT: Expands DNS SPF records, so you don't have to.
13             # The problem is that you only get 10 per SPF records,
14             # and recursions count against you. Your record won't
15             # validate.
16              
17             =head1 NAME
18              
19             Net::DNS::SPF::Expander
20              
21             =head1 DESCRIPTION
22              
23             This module expands DNS SPF records, so you don't have to.
24             The problem is that you only get 10 per SPF record,
25             and recursions count against you. Your record won't
26             validate.
27              
28             Let's say you start with this as an SPF record:
29              
30             @ TXT "v=spf1 include:_spf.google.com include:sendgrid.net a:hq1.campusexplorer.com a:hq2.campusexplorer.com a:mail2.campusexplorer.com ~all"
31              
32             You go to http://www.kitterman.com/spf/validate.html and check this record.
33             It passes validation. But later you come back and add salesforce, so that you
34             now have:
35              
36             @ TXT "v=spf1 include:_spf.google.com include:sendgrid.net include:salesforce.com a:hq1.campusexplorer.com a:hq2.campusexplorer.com a:mail2.campusexplorer.com ~all"
37              
38             And now your record fails validation.
39              
40             _spf.google.com takes 3 lookups.
41             _spf1.google.com
42             _spf2.google.com
43             _spf3.google.com
44             sendgrid.net takes 1 lookup.
45             _sendgrid.biz
46             hq1 takes 1 lookup.
47             hq2 takes 1 lookup.
48             mail2 takes 1 lookup.
49              
50             Salesforce adds:
51              
52             _spf.google.com (3 you already did)
53             _spf1.google.com
54             _spf2.google.com
55             _spf3.google.com
56             mx takes 4 lookups.
57             salesforce.com.s8a1.psmtp.com.
58             salesforce.com.s8a2.psmtp.com.
59             salesforce.com.s8b1.psmtp.com.
60             salesforce.com.s8b2.psmtp.com.
61              
62             So now instead of 7 you have 14. The common advice is to
63             expand them, and that is a tedious process. It's especially
64             tedious when, say, salesforce changes their mx record.
65              
66             So this module and the accompanying script attempt
67             to automate this process for you.
68              
69             =head1 SYNOPSIS
70              
71             Using the script:
72              
73             myhost:~/ $ dns-dpf-expander --input_file zone.db
74             myhost:~/ $ ls
75             zone.db zone.db.new zone.db.bak
76              
77             Using the module:
78              
79             {
80             package MyDNSExpander;
81              
82             use Net::DNS::SPF::Expander;
83              
84             my $input_file = '/home/me/project/etc/zone.db';
85             my $expander = Net::DNS::SPF::Expander->new(
86             input_file => $input_file
87             );
88              
89             my $string = $expander->write;
90              
91             1;
92             }
93              
94             =head1 CONFIGURABLE ATTRIBUTES
95              
96             =head2 input_file
97              
98             This is the path and name of the zonefile whose SPF records you want
99             to expand. It must be a valid L zonefile.
100              
101             =cut
102              
103             option 'input_file' => (
104             is => 'ro',
105             isa => InstanceOf ["Path::Tiny"],
106             coerce => sub { path($_[0]) },
107             required => 1,
108             format => 's',
109             doc => 'The file to be SPF-expanded'
110             );
111              
112             =head2 output_file
113              
114             The path and name of the output file. By default, we tack ".new"
115             onto the end of the original filename.
116              
117             =cut
118              
119             option 'output_file' => (
120             is => 'ro',
121             isa => InstanceOf ["Path::Tiny"],
122             coerce => sub { path($_[0]) },
123             lazy => 1,
124             builder => '_build_output_file',
125             format => 's',
126             doc => 'The destination file to write SPF-expanded records'
127             );
128              
129             =head2 backup_file
130              
131             The path and name of the backup file. By default, we tack ".bak"
132             onto the end of the original filename.
133              
134             =cut
135              
136             has 'backup_file' => (
137             is => 'ro',
138             isa => InstanceOf["Path::Tiny"],
139             lazy => 1,
140             builder => '_build_backup_file',
141             );
142              
143             =head2 nameservers
144              
145             A list of nameservers that will be passed to the resolver.
146              
147             =cut
148              
149             has 'nameservers' => (
150             is => 'ro',
151             isa => Maybe[ArrayRef],
152             );
153              
154             =head2 parsed_file
155              
156             The L object created from the input_file.
157              
158             =cut
159              
160             has 'parsed_file' => (
161             is => 'ro',
162             isa => InstanceOf['Net::DNS::ZoneFile'],
163             lazy => 1,
164             builder => '_build_parsed_file',
165             );
166              
167             =head2 to_expand
168              
169             An arrayref of regexes that we will expand. By default we expand
170             a, mx, include, and redirect records. Configurable.
171              
172             =cut
173              
174             has 'to_expand' => (
175             is => 'ro',
176             isa => ArrayRef[RegexpRef],
177             default => sub {
178             [ qr/^a:/, qr/^mx/, qr/^include/, qr/^redirect/, ];
179             },
180             );
181              
182             =head2 to_copy
183              
184             An arrayref of regexes that we will simply copy over. By default
185             we will copy ip4, ip6, ptr, and exists records. Configurable.
186              
187             =cut
188              
189             has 'to_copy' => (
190             is => 'rw',
191             isa => ArrayRef[RegexpRef],
192             default => sub {
193             [ qr/v=spf1/, qr/^ip4/, qr/^ip6/, qr/^ptr/, qr/^exists/, ];
194             },
195             );
196              
197             =head2 to_ignore
198              
199             An arrayref of regexes that we will ignore. By default we ignore ?all,
200             exp, v=spf1, and ~all.
201              
202             =cut
203              
204             has 'to_ignore' => (
205             is => 'ro',
206             isa => ArrayRef[RegexpRef],
207             default => sub {
208             [ qr/^v=spf1/, qr/^(\??)all/, qr/^exp/, qr/^~all/ ];
209             },
210             );
211              
212             =head2 maximum_record_length
213              
214             We leave out the protocol declaration and the trailing ~all
215             while we are expanding records, so we need to subtract their length
216             from our length calculation.
217              
218             =cut
219              
220             has 'maximum_record_length' => (
221             is => 'ro',
222             isa => Int,
223             default => sub {
224             255 - length('v=spf1 ') - length(' ~all') - length('"') - length('"');
225             },
226             );
227              
228             =head2 ttl
229              
230             Default time to live is 10 minutes. Configurable.
231              
232             =cut
233              
234             has 'ttl' => (
235             is => 'ro',
236             isa => Str,
237             default => sub { '10M' },
238             );
239              
240             =head2 origin
241              
242             The origin of the zonefile. We take it from the zonefile,
243             or you can set it if you like.
244              
245             =cut
246              
247             has 'origin' => (
248             is => 'ro',
249             isa => Str,
250             lazy => 1,
251             builder => '_build_origin',
252             );
253              
254             =head1 PRIVATE ATTRIBUTES
255              
256             =head2 _resource_records
257              
258             An arrayref of all the L resource records
259             found in the entire parsed_file.
260              
261             =cut
262              
263             has '_resource_records' => (
264             is => 'ro',
265             isa => Maybe[ArrayRef[InstanceOf["Net::DNS::RR"]]],
266             lazy => 1,
267             builder => '_build__resource_records',
268             );
269              
270             =head2 _spf_records
271              
272             An arrayref of the L or L
273             records found in the entire parsed_file.
274              
275             =cut
276              
277             has '_spf_records' => (
278             is => 'ro',
279             isa => Maybe[ArrayRef[InstanceOf["Net::DNS::RR"]]],
280             lazy => 1,
281             builder => '_build__spf_records',
282             );
283              
284             =head2 _resolver
285              
286             What we use to do the DNS lookups and expand the records. A
287             L object. You can still set environment
288             variables if you want to change the nameserver it uses.
289              
290             =cut
291              
292             has '_resolver' => (
293             is => 'ro',
294             isa => InstanceOf["Net::DNS::Resolver"],
295             lazy => 1,
296             builder => '_build__resolver',
297             );
298              
299             =head2 _expansions
300              
301             This is a hashref representing the expanded SPF records. The keys
302             are the names of the SPF records, and the values are hashrefs.
303             Those are keyed on the include, and the values are arrayrefs of the
304             expanded values. There is also a key called "elements" which gathers
305             all the includes into one place, e.g.,
306              
307             "*.test_zone.com" => {
308             "~all" => undef,
309             elements => [
310             "ip4:216.239.32.0/19", "ip4:64.233.160.0/19",
311             "ip4:66.249.80.0/20", "ip4:72.14.192.0/18",
312             ...
313             ],
314             "include:_spf.google.com" => [
315             "ip4:216.239.32.0/19",
316             "ip4:64.233.160.0/19",
317             ...
318             ],
319             "ip4:96.43.144.0/20" => [ "ip4:96.43.144.0/20" ],
320             "v=spf1" => undef
321             }
322              
323             They are alpha sorted in the final results for predictability in tests.
324              
325             =cut
326              
327             has '_expansions' => (
328             is => 'ro',
329             isa => HashRef,
330             lazy => 1,
331             builder => '_build__expansions',
332             );
333              
334             =head2 _lengths_of_expansions
335              
336             We need to know how long the expanded record would be, because
337             SPF records should be less than 256 bytes. If the expanded
338             record would be longer than that, we need to split it into
339             pieces.
340              
341             =cut
342              
343             has '_lengths_of_expansions' => (
344             is => 'ro',
345             isa => HashRef,
346             lazy => 1,
347             builder => '_build__lengths_of_expansions',
348             );
349              
350             =head2 _record_class
351              
352             What sort of records are SPF records? IN records.
353              
354             =cut
355              
356             has '_record_class' => (
357             is => 'ro',
358             isa => Str,
359             default => sub {
360             'IN',;
361             },
362             );
363              
364             =head1 BUILDERS
365              
366             =head2 _build_resolver
367              
368             Return a L. Any nameservers will be passed
369             through to the resolver.
370              
371             =cut
372              
373             sub _build__resolver {
374 4     4   41 my $self = shift;
375 4         14 my $nameservers = $self->nameservers;
376 4 50       64 my $resolver = Net::DNS::Resolver->new(
377             recurse => 1,
378             ( $nameservers ? ( nameservers => $nameservers ) : () ),
379             );
380 4         1859 return $resolver;
381             }
382              
383             =head2 _build_origin
384              
385             Extract the origin from parsed_file.
386              
387             =cut
388              
389             sub _build_origin {
390 3     3   142 my $self = shift;
391 3         59 return $self->parsed_file->origin;
392             }
393              
394             =head2 _build_expansions
395              
396             =cut
397              
398             sub _build__expansions {
399 4     4   40 my $self = shift;
400 4         17 return $self->_expand;
401             }
402              
403             =head2 _build_backup_file
404              
405             Tack a ".bak" onto the end of the input_file.
406              
407             =cut
408              
409             sub _build_backup_file {
410 3     3   37 my $self = shift;
411 3         21 my $path = $self->input_file->parent;
412 3         228 my $name = $self->input_file->basename;
413 3         46 return path("${path}/${name}.bak");
414             }
415              
416             =head2 _build_output_file
417              
418             Tack a ".new" onto the end of the input_file.
419              
420             =cut
421              
422             sub _build_output_file {
423 3     3   61 my $self = shift;
424 3         16 my $path = $self->input_file->parent;
425 3         141 my $name = $self->input_file->basename;
426 3         29 return path("${path}/${name}.new");
427             }
428              
429             =head2 _build_parsed_file
430              
431             Turn the L filehandle into a L
432             object, so that we can extract the SPF records.
433              
434             =cut
435              
436             sub _build_parsed_file {
437 4     4   37 my $self = shift;
438 4         31 my $path = $self->input_file->parent;
439 4         455 my $name = $self->input_file->basename;
440 4         55 return Net::DNS::ZoneFile->new("${path}/${name}");
441             }
442              
443             =head2 _build_resource_records
444              
445             Extract all the resource records from the L.
446              
447             =cut
448              
449             sub _build__resource_records {
450 4     4   40 my $self = shift;
451 4         62 my @resource_records = $self->parsed_file->read;
452 4         33124 return \@resource_records;
453             }
454              
455             =head2 _build__spf_records
456              
457             Grep through the _resource_records to find the SPF
458             records. They can be both "TXT" and "SPF" records,
459             so we search for the protocol string, v=spf1.
460              
461             =cut
462              
463             sub _build__spf_records {
464 4     4   40 my $self = shift;
465              
466             # This is crude but correct: SPF records can be both TXT and SPF.
467             my @spf_records =
468 22         560 grep { $_->txtdata =~ /v=spf1/ }
469 38         323 grep { $_->can('txtdata') }
470 4         6 @{ $self->_resource_records };
  4         56  
471 4         166 return \@spf_records;
472             }
473              
474             =head2 _build__lengths_of_expansions
475              
476             Calculate the length of each fully expanded SPF record,
477             because they can't be longer than 256 bytes. We have to split them
478             up into multiple records if they are.
479              
480             =cut
481              
482             sub _build__lengths_of_expansions {
483 4     4   43 my $self = shift;
484 4         63 my $expansions = $self->_expansions;
485 4         107 my $length_per_domain = {};
486 4         15 for my $domain ( keys %$expansions ) {
487             my $record_string = join(
488             ' ',
489 9         13 @{ $expansions->{$domain}{elements} }
  9         62  
490             );
491 9         19 $length_per_domain->{$domain} = length($record_string);
492             }
493 4         67 return $length_per_domain;
494             }
495              
496             =head1 PUBLIC METHODS
497              
498             =head2 write
499              
500             This is the only method you really need to call. This expands all your SPF
501             records and writes out the new and the backup files.
502              
503             Returns a scalar string of the data written to the file.
504              
505             =cut
506              
507             sub write {
508 3     3 1 1242 my $self = shift;
509 3         6 my @new_lines = @{$self->_new_records_lines};
  3         13  
510 3         23 my @input_lines = $self->input_file->lines;
511 3         527 $self->backup_file->spew(@input_lines);
512 3         1751 $self->output_file->spew(@new_lines);
513 3         1221 return join( '', @new_lines );
514             }
515              
516             =head2 new_spf_records
517              
518             In case you want to see how your records were expanded, this returns
519             the hashref of L objects used to create the new records.
520              
521             =cut
522              
523             sub new_spf_records {
524 4     4 1 478 my $self = shift;
525 4         87 my $lengths = $self->_lengths_of_expansions;
526 4         144 my $expansions = $self->_expansions;
527              
528 4         32 my %new_spf_records = ();
529              
530 4         12 for my $domain ( keys %$lengths ) {
531 9         12 my $new_records = [];
532              
533             # We need to make sure the SPF record is less than 256 chars,
534             # including the spf version and trailing ~all.
535 9 50       38 if ( $lengths->{$domain} > $self->maximum_record_length ) {
536             $new_records = $self->_new_records_from_partition(
537             $domain,
538             $expansions->{$domain}{elements},
539 9         29 );
540             } else {
541             $new_records = $self->_new_records_from_arrayref(
542             $domain,
543             $expansions->{$domain}{elements},
544 0         0 );
545             }
546 9         32 $new_spf_records{$domain} = $new_records;
547             }
548 4         28 return \%new_spf_records;
549             }
550              
551             =head1 PRIVATE METHODS
552              
553             =head2 _normalize_component
554              
555             Each component of an SPF record has a prefix, like include:, mx:, etc.
556             Here we chop off the prefix before performing the lookup on the value.
557              
558             =cut
559              
560             sub _normalize_component {
561 226     226   299 my ( $self, $component ) = @_;
562 226         229 my $return = $component;
563 226         663 $return =~ s/^.+?://g;
564 226         379 return $return;
565             }
566              
567             =head2 _perform_expansion
568              
569             Expand a single SPF record component. This returns either undef or the
570             full SPF record string from L->txtdata.
571              
572             =cut
573              
574             sub _perform_expansion {
575 40     40   82 my ( $self, $component ) = @_;
576 40         69 $component = $self->_normalize_component($component);
577 40         579 my $packet = $self->_resolver->search( $component, 'TXT', 'IN' );
578 40 50 33     252932 return unless ($packet) && $packet->isa('Net::DNS::Packet');
579 40         129 my ($answer) = $packet->answer;
580 40 50 33     363 return unless ($answer) && $answer->isa('Net::DNS::RR::TXT');
581 40         162 my $data = $answer->txtdata;
582 40         2197 return $data;
583             }
584              
585             =head2 _expand_spf_component
586              
587             Recursively call _perform_expansion for each component of the SPF record.
588             This returns an array consisting of the component, e.g., include:salesforce.com,
589             and an arrayref consisting of its full expansion, e.g.,
590              
591             [
592             "ip4:216.239.32.0/19",
593             "ip4:64.233.160.0/19",
594             ...
595             "ip6:2c0f:fb50:4000::/36"
596             ]
597              
598             =cut
599              
600             sub _expand_spf_component {
601 947     947   2090 my ( $self, $component, $expansions ) = @_;
602              
603 947   100     1506 $expansions ||= [];
604              
605 947 50       1111 return unless $component;
606              
607 947         1703 my @component_splits = split( ' ', $component );
608 947         1102 my $splits = @component_splits;
609 947 100       1277 if ( $splits > 1 ) {
610 69         100 for my $component (@component_splits) {
611 721         1050 $self->_expand_spf_component( $component, $expansions );
612             }
613             } else {
614 878 100   3239   1777 if (( any { $component =~ $_ } @{ $self->to_ignore } )) {
  3239 100       6525  
  878 100       1734  
615 141         406 return $component;
616 1696     1696   6637 } elsif (( any { $component =~ $_ } @{ $self->to_copy } )) {
  737         10921  
617 695         664 push @{$expansions}, $component;
  695         1181  
618 128     128   317 } elsif (( any { $component =~ $_ } @{ $self->to_expand } )) {
  42         136  
619 40         94 my $new_component = $self->_perform_expansion($component);
620 40         145 $self->_expand_spf_component( $new_component, $expansions );
621             } else {
622 2         9 return $component;
623             }
624             }
625 804         2018 return ( $component, $expansions );
626             }
627              
628             =head2 _expand
629              
630             Create the _expansions hashref from which we generate new SPF records.
631              
632             =cut
633              
634             sub _expand {
635 4     4   6 my $self = shift;
636 4         9 my %spf_hash = ();
637 4         7 my %keys_to_delete = ();
638 4         7 for my $spf_record ( @{ $self->_spf_records } ) {
  4         58  
639 22         444 my @spf_components = split( ' ', $spf_record->txtdata );
640 22         739 for my $spf_component (@spf_components) {
641 186         1639 my $component_name = $self->_normalize_component($spf_component);
642             # We want to make sure that we do not look up spf records that are
643             # defined in this zonefile. So that we could run this tool on a
644             # previously expanded zonefile if we want to. That sort of defeats
645             # the point of the tool, but you may edit the previously expanded zonefile,
646             # adding a new include: or mx, appending it to the other _spfX includes.
647             # We just take the component and its existing expansions and stick them
648             # into the component's parent as a key and value, and then we remove that
649             # component as a separate key from our hash.
650 186 100   2518   458 if ( any { $component_name eq $_->name } @{ $self->_spf_records } ) {
  2518         19069  
  186         2754  
651             my ($zonefile_record)
652 480         3627 = grep { $component_name eq $_->name }
653 30         234 @{ $self->_spf_records };
  30         400  
654 30         281 my ( $comp, $expansions )
655             = $self->_expand_spf_component(
656             $zonefile_record->txtdata );
657 30         73 $spf_hash{ $spf_record->name }{$spf_component} = $expansions;
658 30         377 $keys_to_delete{$component_name} = 1;
659             # If the include or what have you is not defined in the zonefile,
660             # proceed as normal.
661             } else {
662 156         1488 my ( $comp, $expansions )
663             = $self->_expand_spf_component($spf_component);
664 156         424 $spf_hash{ $spf_record->name }{$spf_component} = $expansions;
665             }
666             }
667             my $expansion_elements = $self->_extract_expansion_elements(
668 22         259 $spf_hash{ $spf_record->name } );
669 22         97 $spf_hash{ $spf_record->name }{elements} = $expansion_elements;
670             }
671 4         81 delete @spf_hash{ keys %keys_to_delete };
672 4         83 return \%spf_hash;
673             }
674              
675             =head2 _extract_expansion_elements
676              
677             Filter ignored elements from component expansions.
678              
679             =cut
680              
681             sub _extract_expansion_elements {
682 22     22   200 my ( $self, $expansions ) = @_;
683 22         39 my @elements = ();
684 22         32 my @leading = ();
685 22         32 my @trailing = ();
686 22         83 KEY: for my $key ( keys %$expansions ) {
687 194 100   710   336 if ( any { $key =~ $_ } @{ $self->to_ignore } ) {
  710         1160  
  194         326  
688 34         82 next KEY;
689             }
690 160 50       357 if ( ref( $expansions->{$key} ) eq 'ARRAY' ) {
691 160         143 for my $expansion ( @{ $expansions->{$key} } ) {
  160         196  
692 941         911 push @elements, $expansion;
693             }
694             }
695             }
696             # We sort these so we can be sure of the order in tests.
697 22         141 my @return = uniq sort { $a cmp $b } ( @leading, @elements, @trailing );
  3815         3552  
698 22         124 return \@return;
699             }
700              
701             =head2 _new_records_from_arrayref
702              
703             The full expansion of a given SPF record is contained in an arrayref,
704             and if the length of the resulting new SPF record would be less than the
705             maximum_record_length, we can use this method to make new
706             L objects that will later be stringified for the new
707             SPF record.
708              
709             =cut
710              
711             sub _new_records_from_arrayref {
712 37     37   48 my ( $self, $domain, $expansions ) = @_;
713              
714 37         85 my $txtdata = join(' ', @$expansions);
715              
716 37         41 my @new_records = ();
717 37         134 push @new_records, new Net::DNS::RR(
718             type => 'TXT',
719             name => $domain,
720             class => $self->_record_class,
721             ttl => $self->ttl,
722             txtdata => $txtdata,
723             );
724 37         4371 return \@new_records;
725             }
726              
727             =head2 _new_records_from_partition
728              
729             The full expansion of a given SPF record is contained in an arrayref,
730             and if the length of the resulting new SPF record would be greater than the
731             maximum_record_length, we have to jump through some hoops to properly split
732             it into new SPF records. Because there will be more than one, and each needs
733             to be less than the maximum_record_length. We do our partitioning here, and
734             then call _new_records_from_arrayref on each of the resulting partitions.
735              
736             =cut
737              
738             sub _new_records_from_partition {
739 9     9   16 my ( $self, $domain, $elements, $partitions_only ) = @_;
740 9         118 my $record_string = join( ' ', @$elements );
741 9         16 my $record_length = length($record_string);
742 9         20 my $max_length = $self->maximum_record_length;
743 9         60 my $offset = 0;
744 9         22 my $result = index( $record_string, ' ', $offset );
745 9         78 my @space_indices = ();
746              
747 9         26 while ( $result != -1 ) {
748 340 50       419 push @space_indices, $result if $result;
749 340         276 $offset = $result + 1;
750 340         369 $result = index( $record_string, ' ', $offset );
751             }
752              
753 9 50       61 my $number_of_partitions = int($record_length / $max_length + 0.5)
754             + ( ( $record_length % $max_length ) ? 1 : 0 );
755              
756 9         14 my @partitions = ();
757 9         24 my $partition_offset = 0;
758              
759 9         22 for my $part ( 1 .. $number_of_partitions ) {
760              
761             # We want the first space_index that is
762             # 1. less than the max_length times the number of parts, and
763             # 2. subtracting the partition_offset from it is less than
764             # max_length.
765             my $split_point = first {
766 535 100   535   626 ( $_ < ( $max_length * $part ) )
767             && ( ( $_ - $partition_offset ) < $max_length )
768 37         121 } reverse @space_indices;
769              
770 37         71 my $partition_length = $split_point - $partition_offset;
771              
772             # Go to the end of the string if we are dealing with
773             # the last partition. Otherwise, the last element
774             # gets chopped off, because it is after the last space_index!
775 37 100       51 my $length
776             = ( $part == $number_of_partitions ) ? undef : $partition_length;
777 37         30 my $substring;
778 37 100       43 if ( $part == $number_of_partitions ) {
779             # Go to the end.
780 9         15 $substring = substr( $record_string, $partition_offset );
781             } else {
782             # Take a specific length.
783 28         42 $substring = substr( $record_string, $partition_offset,
784             $partition_length );
785             }
786              
787 37         125 push @partitions, [ split( ' ', $substring ) ];
788 37         61 $partition_offset = $split_point;
789             }
790 9 50       24 return \@partitions if $partitions_only;
791              
792 9         15 my @return = ();
793              
794 9         12 for my $partition (@partitions) {
795 37         65 my $result = $self->_new_records_from_arrayref( $domain, $partition );
796 37         65 push @return, $result;
797             }
798 9         49 return \@return;
799             }
800              
801             =head2 _get_single_record_string
802              
803             Stringify the L records when they will fit into
804             a single SPF record.
805              
806             =cut
807              
808             sub _get_single_record_string {
809 0     0   0 my ( $self, $domain, $record_set ) = @_;
810 0         0 my $origin = $self->origin;
811              
812 0         0 my @record_strings = ();
813              
814 0         0 my @sorted_record_set = map { $_ }
815 0         0 sort { $a->string cmp $b->string }
  0         0  
816             @$record_set;
817              
818 0         0 for my $record (@sorted_record_set) {
819 0         0 $record->name($domain);
820 0         0 $record->txtdata( 'v=spf1 ' . $record->txtdata . ' ~all' );
821              
822 0         0 my $string = $self->_normalize_record_name( $record->string );
823 0         0 push @record_strings, $string;
824             }
825 0         0 return \@record_strings;
826             }
827              
828             =head2 _normalize_record_name
829              
830             L uses fully qualified record names, so that new SPF records
831             will be named *.domain.com, and domain.com, instead of * and @. I prefer
832             the symbols. This code replaces the fully qualified record names with symbols.
833              
834             =cut
835              
836             sub _normalize_record_name {
837 19     19   3371 my ( $self, $record ) = @_;
838              
839 19         63 $record =~ /(.+?)\s/;
840 19         41 my $original_name = $1;
841 19         335 my $origin = $self->origin;
842              
843 19         114 my $name;
844              
845 19 100       145 if ( $original_name =~ /^$origin(.?)$/ ) {
    50          
    100          
846 3         6 $name = '@';
847             } elsif ( $original_name =~ /^\.$/ ) {
848 0         0 $name = '@';
849             } elsif ( $original_name =~ /^\*/ ) {
850 3         7 $name = '*';
851             } else {
852 13         17 $name = $original_name;
853             }
854 19         263 $record =~ s/\Q$original_name\E/$name/g;
855 19         68 $record =~ s/\n//g;
856 19         99 $record =~ s/(\(|\))//g;
857 19         65 $record =~ s/\t\s/\t/g;
858 19         36 $record =~ s/\s\t/\t/g;
859 19         24 $record =~ s/\t\t/\t/g;
860 19         57 $record =~ s/\t/ /g;
861 19         196 $record =~ s/\s/ /g;
862 19         27 $record = $record."\n";
863 19         57 return $record;
864             }
865              
866             =head2 _get_multiple_record_strings
867              
868             Whereas a single new SPF record needs to be concatenated from
869             the stringified Ls, and have the trailing
870             ~all added, multiple new SPF records do not need that. They need to be given
871             special _spf names that will then be included in "master" SPF records, and
872             they don't need the trailing ~all.
873              
874             =cut
875              
876             sub _get_multiple_record_strings {
877 3     3   8 my ( $self, $values, $start_index ) = @_;
878 3         50 my $origin = $self->origin;
879              
880 3         19 my @record_strings = ();
881              
882 3         5 my @containing_records = ();
883              
884 3   50     15 my $i = $start_index // 1;
885 3         9 for my $value (@$values) {
886 12         68 push @containing_records,
887             new Net::DNS::RR(
888             type => 'TXT',
889             name => "_spf$i.$origin",
890             class => $self->_record_class,
891             ttl => $self->ttl,
892             txtdata => 'v=spf1 ' . $value,
893             );
894 12         1594 $i++;
895             }
896              
897             @record_strings = map {
898 12         1010 $self->_normalize_record_name($_->string)
899             } sort {
900 3         10 $a->string cmp $b->string
  15         5007  
901             } @containing_records;
902              
903 3         23 return \@record_strings;
904             }
905              
906             =head2 _get_master_record_strings
907              
908             Create our "master" SPF records that include the split _spf records created
909             in _get_multiple_record_strings, e.g.,
910              
911             * 600 IN TXT "v=spf1 include:_spf1.test_zone.com include:_spf2.test_zone.com ~all"
912              
913             =cut
914              
915             sub _get_master_record_strings {
916 3     3   8 my ( $self, $values, $domains ) = @_;
917              
918 3         79 (my $origin = $self->origin) =~ s/\.$//g;
919 3         551 my @record_strings = ();
920              
921 3         7 my @containing_records = ();
922              
923 3         10 my $master_records = [ map {"include:_spf$_.$origin"} ( 1 .. scalar(@$values)) ];
  12         31  
924 3         18 my $master_record = join(' ', @$master_records);
925              
926             # If our master record will be too long, split it into multiple strings
927 3 50       18 if (length($master_record) > $self->maximum_record_length) {
928              
929 0         0 my $new_master_record_partitions = $self->_new_records_from_partition(
930             "master",
931             $master_records,
932             1, # Just return raw partitions
933             );
934              
935 0         0 my @master_record_strings = ();
936 0         0 my $i = 0;
937 0         0 for my $partition (@$new_master_record_partitions) {
938 0         0 my @master_record_partition = @$master_records[$i .. ($i + $#{$partition})];
  0         0  
939 0         0 push @master_record_strings, join(' ', @master_record_partition);
940 0         0 $i += scalar(@$partition);
941             }
942 0         0 $master_record_strings[0] = 'v=spf1 '. $master_record_strings[0];
943 0         0 $master_record_strings[-1] = $master_record_strings[-1].' ~all';
944 0         0 my $master_record_string = '';
945 0         0 my $index = 0;
946 0         0 for my $master_record (@master_record_strings) {
947 0 0       0 $master_record = " ".$master_record unless $index == 0;
948 0         0 $master_record_string .= qq|"$master_record"|;
949 0         0 $index++;
950             }
951              
952 0         0 for my $domain (@$domains) {
953              
954 0         0 push @containing_records,
955             new Net::DNS::RR(
956             type => 'TXT',
957             name => $domain,
958             class => $self->_record_class,
959             ttl => $self->ttl,
960             txtdata => \@master_record_strings,
961             );
962             }
963              
964             # Otherwise, proceed as normal
965             } else {
966              
967 3         8 for my $domain (@$domains) {
968              
969             push @containing_records,
970             new Net::DNS::RR(
971             type => 'TXT',
972             name => $domain,
973             class => $self->_record_class,
974             ttl => $self->ttl,
975             txtdata => 'v=spf1 ' . (join(
976             ' ',
977 7         467 ( map {"include:_spf$_.$origin"} ( 1 .. scalar(@$values) ) )
  30         85  
978             )) . ' ~all',
979             );
980             }
981              
982             }
983              
984             @record_strings = map {
985 7         1352 $self->_normalize_record_name($_->string)
986             } sort {
987 3         305 $a->string cmp $b->string
  4         642  
988             } @containing_records;
989              
990 3         35 return \@record_strings;
991             }
992              
993             =head2 _new_records_lines
994              
995             Assemble the new DNS zonefile from the lines of the original,
996             comment out the old SPF records, add in the new lines, and append the
997             end of the original.
998              
999             =cut
1000              
1001             sub _new_records_lines {
1002 3     3   4 my $self = shift;
1003 3 50       5 my %new_records = %{ $self->new_spf_records || {} };
  3         10  
1004 3         9 my @record_strings = ();
1005              
1006             # Make a list of the unique records in case we need it.
1007 3         6 my @autosplit = ();
1008 3         9 for my $domain ( keys %new_records ) {
1009 7         77 for my $record_set ( @{ $new_records{$domain} } ) {
  7         11  
1010 30 50       473 if ( ref($record_set) eq 'ARRAY' ) {
1011 30         38 for my $record (@$record_set) {
1012 30         48 push @autosplit, $record->txtdata;
1013             }
1014             } else {
1015 0         0 push @autosplit, $record_set->txtdata;
1016             }
1017             }
1018             }
1019 3         77 @autosplit = uniq @autosplit;
1020              
1021             # If there are any autosplit SPF records, we just do that right away.
1022             # This test is kind of nasty.
1023             my $make_autosplit_records = grep {
1024 3         17 defined( ${ $new_records{$_} }[0] )
  7         22  
1025 7 50       7 && ref( ${ $new_records{$_} }[0] ) eq 'ARRAY'
  7         21  
1026             } sort keys %new_records;
1027 3 50       9 if ($make_autosplit_records) {
1028 3         17 my $master_record_strings
1029             = $self->_get_master_record_strings( \@autosplit,
1030             [ keys %new_records ] );
1031 3         14 my $record_strings
1032             = $self->_get_multiple_record_strings( \@autosplit );
1033 3         9 push @record_strings, @$master_record_strings;
1034 3         10 push @record_strings, @$record_strings;
1035             } else {
1036 0         0 for my $domain ( sort keys %new_records ) {
1037             my $record_string = $self->_get_single_record_string(
1038             $domain,
1039 0         0 $new_records{$domain},
1040             );
1041 0         0 push @record_strings, @$record_string;
1042             }
1043             }
1044 3         31 my @original_lines = $self->input_file->lines;
1045 3         760 my @new_lines = ();
1046 3         5 my @spf_indices;
1047 3         8 my $i = 0;
1048 3         6 LINE: for my $line (@original_lines) {
1049 44 100       148 if ( $line =~ /^[^;].+?v=spf1/ ) {
1050 20         27 push @spf_indices, $i;
1051 20         35 $line = ";" . $line;
1052             }
1053 44         83 push @new_lines, $line;
1054 44         43 $i++;
1055             }
1056 3         17 my @first_segment = @new_lines[ 0 .. $spf_indices[-1] ];
1057 3         12 my @last_segment = @new_lines[ $spf_indices[-1] + 1 .. $#new_lines ];
1058 3         11 my @final_lines = ( @first_segment, @record_strings, @last_segment );
1059              
1060 3         8 for my $line (@final_lines) {
1061 63         67 $line =~ s/\t/ /g;
1062 63         53 $line =~ s/\n\s+/\n/g;
1063 63         161 $line =~ s/\s+\n/\n/g;
1064 63         142 $line =~ s/\n+/\n/g;
1065             }
1066 3         71 return \@final_lines;
1067             }
1068              
1069             __PACKAGE__->meta->make_immutable;
1070             __PACKAGE__->new_with_options->run unless caller;
1071              
1072             1;
1073              
1074             __END__