File Coverage

blib/lib/Validate/SPF/Parser.pm
Criterion Covered Total %
statement 112 169 66.2
branch 40 72 55.5
condition 4 12 33.3
subroutine 15 25 60.0
pod n/a
total 171 278 61.5


line stmt bran cond sub pod time code
1             package Validate::SPF::Parser;
2              
3             # ABSTRACT: SPF v1 parser implementation
4              
5             ####################################################################
6             #
7             # This file was generated using Parse::Yapp version 1.05.
8             #
9             # Don't edit this file, use source file instead.
10             #
11             # ANY CHANGE MADE HERE WILL BE LOST !
12             #
13             ####################################################################
14              
15 10     10   839493 use strict;
  10         22  
  10         326  
16 10     10   43 use warnings;
  10         14  
  10         467  
17              
18             our $VERSION = '0.004'; # VERSION
19             our $AUTHORITY = 'cpan:CHIM'; # AUTHORITY
20              
21 10     10   39 use vars qw ( @ISA );
  10         14  
  10         841  
22              
23             @ISA = qw( Parse::Yapp::Driver );
24              
25             #Included Parse/Yapp/Driver.pm file----------------------------------------
26             {
27             #
28             # Module Parse::Yapp::Driver
29             #
30             # This module is part of the Parse::Yapp package available on your
31             # nearest CPAN
32             #
33             # Any use of this module in a standalone parser make the included
34             # text under the same copyright as the Parse::Yapp module itself.
35             #
36             # This notice should remain unchanged.
37             #
38             # (c) Copyright 1998-2001 Francois Desarmenien, all rights reserved.
39             # (see the pod text in Parse::Yapp module for use and distribution rights)
40             #
41              
42             package Parse::Yapp::Driver;
43              
44             require 5.004;
45              
46 10     10   49 use strict;
  10         12  
  10         328  
47              
48 10     10   42 use vars qw ( $VERSION $COMPATIBLE $FILENAME );
  10         12  
  10         639  
49              
50             $VERSION = '1.05';
51             $COMPATIBLE = '0.07';
52             $FILENAME=__FILE__;
53              
54 10     10   47 use Carp;
  10         9  
  10         9069  
55              
56             #Known parameters, all starting with YY (leading YY will be discarded)
57             my(%params)=(YYLEX => 'CODE', 'YYERROR' => 'CODE', YYVERSION => '',
58             YYRULES => 'ARRAY', YYSTATES => 'ARRAY', YYDEBUG => '');
59             #Mandatory parameters
60             my(@params)=('LEX','RULES','STATES');
61              
62             sub new {
63 10     10   37 my($class)=shift;
64 10         22 my($errst,$nberr,$token,$value,$check,$dotpos);
65 10         116 my($self)={ ERROR => \&_Error,
66             ERRST => \$errst,
67             NBERR => \$nberr,
68             TOKEN => \$token,
69             VALUE => \$value,
70             DOTPOS => \$dotpos,
71             STACK => [],
72             DEBUG => 0,
73             CHECK => \$check };
74              
75 10         57 _CheckParams( [], \%params, \@_, $self );
76              
77 10 50 33     138 exists($$self{VERSION})
78             and $$self{VERSION} < $COMPATIBLE
79             and croak "Yapp driver version $VERSION ".
80             "incompatible with version $$self{VERSION}:\n".
81             "Please recompile parser module.";
82              
83 10 50       31 ref($class)
84             and $class=ref($class);
85              
86 10         65 bless($self,$class);
87             }
88              
89             sub YYParse {
90 117     117   191 my($self)=shift;
91 117         132 my($retval);
92              
93 117         440 _CheckParams( \@params, \%params, \@_, $self );
94              
95 117 50       376 if($$self{DEBUG}) {
96 0         0 _DBLoad();
97 0         0 $retval = eval '$self->_DBParse()';#Do not create stab entry on compile
98 0 0       0 $@ and die $@;
99             }
100             else {
101 117         527 $retval = $self->_Parse();
102             }
103 117         616 $retval
104             }
105              
106             sub YYData {
107 1383     1383   1499 my($self)=shift;
108              
109 1383 100       2565 exists($$self{USER})
110             or $$self{USER}={};
111              
112 1383         4844 $$self{USER};
113              
114             }
115              
116             sub YYErrok {
117 0     0   0 my($self)=shift;
118              
119 0         0 ${$$self{ERRST}}=0;
  0         0  
120 0         0 undef;
121             }
122              
123             sub YYNberr {
124 0     0   0 my($self)=shift;
125              
126 0         0 ${$$self{NBERR}};
  0         0  
127             }
128              
129             sub YYRecovering {
130 0     0   0 my($self)=shift;
131              
132 0         0 ${$$self{ERRST}} != 0;
  0         0  
133             }
134              
135             sub YYAbort {
136 0     0   0 my($self)=shift;
137              
138 0         0 ${$$self{CHECK}}='ABORT';
  0         0  
139 0         0 undef;
140             }
141              
142             sub YYAccept {
143 60     60   152 my($self)=shift;
144              
145 60         75 ${$$self{CHECK}}='ACCEPT';
  60         118  
146 60         92 undef;
147             }
148              
149             sub YYError {
150 49     49   76 my($self)=shift;
151              
152 49         60 ${$$self{CHECK}}='ERROR';
  49         107  
153 49         100 undef;
154             }
155              
156             sub YYSemval {
157 0     0   0 my($self)=shift;
158 0         0 my($index)= $_[0] - ${$$self{DOTPOS}} - 1;
  0         0  
159              
160 0         0 $index < 0
161 0 0 0     0 and -$index <= @{$$self{STACK}}
162             and return $$self{STACK}[$index][1];
163              
164 0         0 undef; #Invalid index
165             }
166              
167             sub YYCurtok {
168 0     0   0 my($self)=shift;
169              
170             @_
171 0 0       0 and ${$$self{TOKEN}}=$_[0];
  0         0  
172 0         0 ${$$self{TOKEN}};
  0         0  
173             }
174              
175             sub YYCurval {
176 16     16   29 my($self)=shift;
177              
178             @_
179 16 50       97 and ${$$self{VALUE}}=$_[0];
  0         0  
180 16         21 ${$$self{VALUE}};
  16         120  
181             }
182              
183             sub YYExpect {
184 0     0   0 my($self)=shift;
185              
186 0         0 keys %{$self->{STATES}[$self->{STACK}[-1][0]]{ACTIONS}}
  0         0  
187             }
188              
189             sub YYLexer {
190 0     0   0 my($self)=shift;
191              
192 0         0 $$self{LEX};
193             }
194              
195              
196             #################
197             # Private stuff #
198             #################
199              
200              
201             sub _CheckParams {
202 127     127   265 my($mandatory,$checklist,$inarray,$outhash)=@_;
203 127         154 my($prm,$value);
204 127         293 my($prmlst)={};
205              
206 127         582 while(($prm,$value)=splice(@$inarray,0,2)) {
207 264         437 $prm=uc($prm);
208 264 50       719 exists($$checklist{$prm})
209             or croak("Unknow parameter '$prm'");
210 264 50       675 ref($value) eq $$checklist{$prm}
211             or croak("Invalid value for parameter '$prm'");
212 264         792 $prm=unpack('@2A*',$prm);
213 264         861 $$outhash{$prm}=$value;
214             }
215 127         300 for (@$mandatory) {
216 351 50       908 exists($$outhash{$_})
217             or croak("Missing mandatory parameter '".lc($_)."'");
218             }
219             }
220              
221             sub _Error {
222 0     0   0 print "Parse error.\n";
223             }
224              
225             sub _DBLoad {
226             {
227 10     10   58 no strict 'refs';
  10     0   14  
  10         10603  
  0         0  
228              
229 0 0       0 exists(${__PACKAGE__.'::'}{_DBParse})#Already loaded ?
  0         0  
230             and return;
231             }
232 0         0 my($fname)=__FILE__;
233 0         0 my(@drv);
234 0 0       0 open(DRV,"<$fname") or die "Report this as a BUG: Cannot open $fname";
235 0         0 while() {
236             /^\s*sub\s+_Parse\s*{\s*$/ .. /^\s*}\s*#\s*_Parse\s*$/
237 0 0       0 and do {
238 0         0 s/^#DBG>//;
239 0         0 push(@drv,$_);
240             }
241             }
242 0         0 close(DRV);
243              
244 0         0 $drv[0]=~s/_P/_DBP/;
245 0         0 eval join('',@drv);
246             }
247              
248             #Note that for loading debugging version of the driver,
249             #this file will be parsed from 'sub _Parse' up to '}#_Parse' inclusive.
250             #So, DO NOT remove comment at end of sub !!!
251             sub _Parse {
252 117     117   203 my($self)=shift;
253              
254 117         346 my($rules,$states,$lex,$error)
255             = @$self{ 'RULES', 'STATES', 'LEX', 'ERROR' };
256 117         379 my($errstatus,$nberror,$token,$value,$stack,$check,$dotpos)
257             = @$self{ 'ERRST', 'NBERR', 'TOKEN', 'VALUE', 'STACK', 'CHECK', 'DOTPOS' };
258              
259             #DBG> my($debug)=$$self{DEBUG};
260             #DBG> my($dbgerror)=0;
261              
262             #DBG> my($ShowCurToken) = sub {
263             #DBG> my($tok)='>';
264             #DBG> for (split('',$$token)) {
265             #DBG> $tok.= (ord($_) < 32 or ord($_) > 126)
266             #DBG> ? sprintf('<%02X>',ord($_))
267             #DBG> : $_;
268             #DBG> }
269             #DBG> $tok.='<';
270             #DBG> };
271              
272 117         155 $$errstatus=0;
273 117         135 $$nberror=0;
274 117         221 ($$token,$$value)=(undef,undef);
275 117         345 @$stack=( [ 0, undef ] );
276 117         182 $$check='';
277              
278 117         119 while(1) {
279 881         721 my($actions,$act,$stateno);
280              
281 881         1016 $stateno=$$stack[-1][0];
282 881         952 $actions=$$states[$stateno];
283              
284             #DBG> print STDERR ('-' x 40),"\n";
285             #DBG> $debug & 0x2
286             #DBG> and print STDERR "In state $stateno:\n";
287             #DBG> $debug & 0x08
288             #DBG> and print STDERR "Stack:[".
289             #DBG> join(',',map { $$_[0] } @$stack).
290             #DBG> "]\n";
291              
292              
293 881 100       1558 if (exists($$actions{ACTIONS})) {
294              
295             defined($$token)
296 597 100       975 or do {
297 489         1024 ($$token,$$value)=&$lex($self);
298             #DBG> $debug & 0x01
299             #DBG> and print STDERR "Need token. Got ".&$ShowCurToken."\n";
300             };
301              
302 597 100       18392 $act= exists($$actions{ACTIONS}{$$token})
    100          
303             ? $$actions{ACTIONS}{$$token}
304             : exists($$actions{DEFAULT})
305             ? $$actions{DEFAULT}
306             : undef;
307             }
308             else {
309 284         355 $act=$$actions{DEFAULT};
310             #DBG> $debug & 0x01
311             #DBG> and print STDERR "Don't need token.\n";
312             }
313              
314             defined($act)
315 881 100       1472 and do {
316              
317             $act > 0
318 873 100       1383 and do { #shift
319              
320             #DBG> $debug & 0x04
321             #DBG> and print STDERR "Shift and go to state $act.\n";
322              
323             $$errstatus
324 460 50       750 and do {
325 0         0 --$$errstatus;
326              
327             #DBG> $debug & 0x10
328             #DBG> and $dbgerror
329             #DBG> and $$errstatus == 0
330             #DBG> and do {
331             #DBG> print STDERR "**End of Error recovery.\n";
332             #DBG> $dbgerror=0;
333             #DBG> };
334             };
335              
336              
337 460         913 push(@$stack,[ $act, $$value ]);
338              
339 460 100       1052 $$token ne '' #Don't eat the eof
340             and $$token=$$value=undef;
341 460         568 next;
342             };
343              
344             #reduce
345 413         354 my($lhs,$len,$code,@sempar,$semval);
346 413         368 ($lhs,$len,$code)=@{$$rules[-$act]};
  413         975  
347              
348             #DBG> $debug & 0x04
349             #DBG> and $act
350             #DBG> and print STDERR "Reduce using rule ".-$act." ($lhs,$len): ";
351              
352 413 100       1013 $act
353             or $self->YYAccept();
354              
355 413         390 $$dotpos=$len;
356              
357             unpack('A1',$lhs) eq '@' #In line rule
358 413 50       1226 and do {
359 0 0       0 $lhs =~ /^\@[0-9]+\-([0-9]+)$/
360             or die "In line rule name '$lhs' ill formed: ".
361             "report it as a BUG.\n";
362 0         0 $$dotpos = $1;
363             };
364              
365 760         1375 @sempar = $$dotpos
366 413 50       1212 ? map { $$_[1] } @$stack[ -$$dotpos .. -1 ]
367             : ();
368              
369 413 50       1211 $semval = $code ? &$code( $self, @sempar )
    100          
370             : @sempar ? $sempar[0] : undef;
371              
372 413         716 splice(@$stack,-$len,$len);
373              
374             $$check eq 'ACCEPT'
375 413 100       821 and do {
376              
377             #DBG> $debug & 0x04
378             #DBG> and print STDERR "Accept.\n";
379              
380 60         193 return($semval);
381             };
382              
383             $$check eq 'ABORT'
384 353 50       606 and do {
385              
386             #DBG> $debug & 0x04
387             #DBG> and print STDERR "Abort.\n";
388              
389 0         0 return(undef);
390              
391             };
392              
393             #DBG> $debug & 0x04
394             #DBG> and print STDERR "Back to state $$stack[-1][0], then ";
395              
396             $$check eq 'ERROR'
397 353 100       606 or do {
398             #DBG> $debug & 0x04
399             #DBG> and print STDERR
400             #DBG> "go to state $$states[$$stack[-1][0]]{GOTOS}{$lhs}.\n";
401              
402             #DBG> $debug & 0x10
403             #DBG> and $dbgerror
404             #DBG> and $$errstatus == 0
405             #DBG> and do {
406             #DBG> print STDERR "**End of Error recovery.\n";
407             #DBG> $dbgerror=0;
408             #DBG> };
409              
410 304         748 push(@$stack,
411             [ $$states[$$stack[-1][0]]{GOTOS}{$lhs}, $semval ]);
412 304         355 $$check='';
413 304         427 next;
414             };
415              
416             #DBG> $debug & 0x04
417             #DBG> and print STDERR "Forced Error recovery.\n";
418              
419 49         158 $$check='';
420              
421             };
422              
423             #Error
424             $$errstatus
425 57 50       134 or do {
426              
427 57         68 $$errstatus = 1;
428 57         141 &$error($self);
429 57 50       121 $$errstatus # if 0, then YYErrok has been called
430             or next; # so continue parsing
431              
432             #DBG> $debug & 0x10
433             #DBG> and do {
434             #DBG> print STDERR "**Entering Error recovery.\n";
435             #DBG> ++$dbgerror;
436             #DBG> };
437              
438 57         78 ++$$nberror;
439              
440             };
441              
442             $$errstatus == 3 #The next token is not valid: discard it
443 57 50       186 and do {
444             $$token eq '' # End of input: no hope
445 0 0       0 and do {
446             #DBG> $debug & 0x10
447             #DBG> and print STDERR "**At eof: aborting.\n";
448 0         0 return(undef);
449             };
450              
451             #DBG> $debug & 0x10
452             #DBG> and print STDERR "**Dicard invalid token ".&$ShowCurToken.".\n";
453              
454 0         0 $$token=$$value=undef;
455             };
456              
457 57         67 $$errstatus=3;
458              
459 57   33     594 while( @$stack
      66        
460             and ( not exists($$states[$$stack[-1][0]]{ACTIONS})
461             or not exists($$states[$$stack[-1][0]]{ACTIONS}{error})
462             or $$states[$$stack[-1][0]]{ACTIONS}{error} <= 0)) {
463              
464             #DBG> $debug & 0x10
465             #DBG> and print STDERR "**Pop state $$stack[-1][0].\n";
466              
467 61         209 pop(@$stack);
468             }
469              
470             @$stack
471 57 50       130 or do {
472              
473             #DBG> $debug & 0x10
474             #DBG> and print STDERR "**No state left on stack: aborting.\n";
475              
476 57         139 return(undef);
477             };
478              
479             #shift the error token
480              
481             #DBG> $debug & 0x10
482             #DBG> and print STDERR "**Shift \$error token and go to state ".
483             #DBG> $$states[$$stack[-1][0]]{ACTIONS}{error}.
484             #DBG> ".\n";
485              
486 0           push(@$stack, [ $$states[$$stack[-1][0]]{ACTIONS}{error}, undef ]);
487              
488             }
489              
490             #never reached
491 0           croak("Error in driver logic. Please, report it as a BUG");
492              
493             }#_Parse
494             #DO NOT remove comment
495              
496             1;
497              
498             }
499             #End of include--------------------------------------------------
500              
501              
502             #line 1 "Parser.yp"
503             #
504             # Validate::SPF::Parser source file
505             #
506             # Author: Anton Gerasimov
507             #
508              
509             use Regexp::Common qw( net );
510              
511             my $input;
512              
513             my %errors = (
514             E_DEFAULT => "Just error",
515             E_SYNTAX => "Syntax error near token '%s'",
516             E_INVALID_VERSION => "Invalid SPF version",
517             E_IPADDR_EXPECTED => "Expected ip or network address",
518             E_DOMAIN_EXPECTED => "Expected domain name",
519             E_UNEXPECTED_BITMASK => "Unexpected bitmask",
520             E_UNEXPECTED_IPADDR => "Unexpected ip address",
521             E_UNEXPECTED_DOMAIN => "Unexpected domain name",
522             );
523              
524              
525              
526              
527             sub new {
528             my( $class ) = shift;
529              
530             ref( $class ) and $class = ref( $class );
531              
532             my $self =
533             $class->SUPER::new(
534             yyversion => '1.05',
535             yystates => [
536             {#State 0
537             ACTIONS => {
538             'MECHANISM' => 2,
539             'MODIFIER' => 3,
540             'QUALIFIER' => 7,
541             'VERSION' => 13
542             },
543             GOTOS => {
544             'mechanism' => 1,
545             'version' => 6,
546             'with_bitmask' => 5,
547             'with_domain' => 4,
548             'with_domain_bitmask' => 8,
549             'modifier' => 9,
550             'chunks' => 10,
551             'with_ipaddress' => 11,
552             'chunk' => 14,
553             'spf' => 12
554             }
555             },
556             {#State 1
557             DEFAULT => -6
558             },
559             {#State 2
560             ACTIONS => {
561             ":" => 15,
562             "/" => 16
563             },
564             DEFAULT => -13
565             },
566             {#State 3
567             ACTIONS => {
568             "=" => 17
569             }
570             },
571             {#State 4
572             DEFAULT => -11
573             },
574             {#State 5
575             DEFAULT => -10
576             },
577             {#State 6
578             DEFAULT => -5
579             },
580             {#State 7
581             ACTIONS => {
582             'MECHANISM' => 18
583             }
584             },
585             {#State 8
586             DEFAULT => -9
587             },
588             {#State 9
589             DEFAULT => -7
590             },
591             {#State 10
592             ACTIONS => {
593             'MECHANISM' => 2,
594             'MODIFIER' => 3,
595             'QUALIFIER' => 7,
596             'VERSION' => 13
597             },
598             DEFAULT => -1,
599             GOTOS => {
600             'mechanism' => 1,
601             'version' => 6,
602             'with_bitmask' => 5,
603             'with_domain' => 4,
604             'with_domain_bitmask' => 8,
605             'modifier' => 9,
606             'with_ipaddress' => 11,
607             'chunk' => 19
608             }
609             },
610             {#State 11
611             DEFAULT => -8
612             },
613             {#State 12
614             ACTIONS => {
615             '' => 20
616             }
617             },
618             {#State 13
619             DEFAULT => -2
620             },
621             {#State 14
622             DEFAULT => -4
623             },
624             {#State 15
625             ACTIONS => {
626             'DOMAIN' => 21,
627             'IPADDRESS' => 22
628             }
629             },
630             {#State 16
631             ACTIONS => {
632             'BITMASK' => 23
633             }
634             },
635             {#State 17
636             ACTIONS => {
637             'DOMAIN' => 24
638             }
639             },
640             {#State 18
641             ACTIONS => {
642             ":" => 25,
643             "/" => 26
644             },
645             DEFAULT => -14
646             },
647             {#State 19
648             DEFAULT => -3
649             },
650             {#State 20
651             DEFAULT => 0
652             },
653             {#State 21
654             ACTIONS => {
655             "/" => 27
656             },
657             DEFAULT => -15
658             },
659             {#State 22
660             ACTIONS => {
661             "/" => 28
662             },
663             DEFAULT => -21
664             },
665             {#State 23
666             DEFAULT => -17
667             },
668             {#State 24
669             DEFAULT => -12
670             },
671             {#State 25
672             ACTIONS => {
673             'DOMAIN' => 29,
674             'IPADDRESS' => 30
675             }
676             },
677             {#State 26
678             ACTIONS => {
679             'BITMASK' => 31
680             }
681             },
682             {#State 27
683             ACTIONS => {
684             'BITMASK' => 32
685             }
686             },
687             {#State 28
688             ACTIONS => {
689             'BITMASK' => 33
690             }
691             },
692             {#State 29
693             ACTIONS => {
694             "/" => 34
695             },
696             DEFAULT => -16
697             },
698             {#State 30
699             ACTIONS => {
700             "/" => 35
701             },
702             DEFAULT => -22
703             },
704             {#State 31
705             DEFAULT => -18
706             },
707             {#State 32
708             DEFAULT => -19
709             },
710             {#State 33
711             DEFAULT => -23
712             },
713             {#State 34
714             ACTIONS => {
715             'BITMASK' => 36
716             }
717             },
718             {#State 35
719             ACTIONS => {
720             'BITMASK' => 37
721             }
722             },
723             {#State 36
724             DEFAULT => -20
725             },
726             {#State 37
727             DEFAULT => -24
728             }
729             ],
730             yyrules => [
731             [#Rule 0
732             '$start', 2, undef
733             ],
734             [#Rule 1
735             'spf', 1,
736             sub
737             #line 28 "Parser.yp"
738             { $_[1] }
739             ],
740             [#Rule 2
741             'version', 1,
742             sub
743             #line 33 "Parser.yp"
744             {
745             $_[1] eq 'v=spf1' and
746             return $_[0]->_ver_generic( $_[1] );
747              
748             $_[0]->raise_error( 'E_INVALID_VERSION', $_[1] );
749             }
750             ],
751             [#Rule 3
752             'chunks', 2,
753             sub
754             #line 43 "Parser.yp"
755             { push( @{$_[1]}, $_[2] ) if defined $_[2]; $_[1] }
756             ],
757             [#Rule 4
758             'chunks', 1,
759             sub
760             #line 45 "Parser.yp"
761             { defined $_[1] ? [ $_[1] ] : [ ] }
762             ],
763             [#Rule 5
764             'chunk', 1, undef
765             ],
766             [#Rule 6
767             'chunk', 1, undef
768             ],
769             [#Rule 7
770             'chunk', 1, undef
771             ],
772             [#Rule 8
773             'mechanism', 1, undef
774             ],
775             [#Rule 9
776             'mechanism', 1, undef
777             ],
778             [#Rule 10
779             'mechanism', 1, undef
780             ],
781             [#Rule 11
782             'mechanism', 1, undef
783             ],
784             [#Rule 12
785             'modifier', 3,
786             sub
787             #line 63 "Parser.yp"
788             {
789             $_[0]->_mod_generic( $_[1], $_[3] );
790             }
791             ],
792             [#Rule 13
793             'with_domain', 1,
794             sub
795             #line 71 "Parser.yp"
796             {
797             $_[0]->raise_error( 'E_IPADDR_EXPECTED', $_[1] )
798             if $_[1] =~ /ip[46]/i;
799             $_[0]->raise_error( 'E_DOMAIN_EXPECTED', $_[1] )
800             if $_[1] =~ /\A(exists|include)\Z/i;
801              
802             $_[0]->_mech_domain( '+', $_[1], $_[1] =~ /all/i ? undef : '@' );
803             }
804             ],
805             [#Rule 14
806             'with_domain', 2,
807             sub
808             #line 80 "Parser.yp"
809             {
810             $_[0]->raise_error( 'E_IPADDR_EXPECTED', $_[1] . $_[2] )
811             if $_[2] =~ /ip[46]/i;
812             $_[0]->raise_error( 'E_DOMAIN_EXPECTED', $_[1] . $_[2] )
813             if $_[2] =~ /\A(exists|include)\Z/i;
814              
815             $_[0]->_mech_domain( $_[1], $_[2], $_[2] =~ /all/i ? undef : '@' );
816             }
817             ],
818             [#Rule 15
819             'with_domain', 3,
820             sub
821             #line 89 "Parser.yp"
822             {
823             my $ctx = $_[1] . ':' . $_[3];
824              
825             $_[0]->raise_error( 'E_UNEXPECTED_DOMAIN', $ctx )
826             if $_[1] =~ /all/i;
827              
828             $_[0]->_mech_domain( '+', $_[1], $_[3] );
829             }
830             ],
831             [#Rule 16
832             'with_domain', 4,
833             sub
834             #line 98 "Parser.yp"
835             {
836             my $ctx = $_[1] . $_[2] . ':' . $_[4];
837              
838             $_[0]->raise_error( 'E_UNEXPECTED_DOMAIN', $ctx )
839             if $_[2] =~ /all/i;
840              
841             $_[0]->_mech_domain( $_[1], $_[2], $_[4] );
842             }
843             ],
844             [#Rule 17
845             'with_bitmask', 3,
846             sub
847             #line 111 "Parser.yp"
848             {
849             my $ctx = $_[1] . '/' . $_[3];
850              
851             $_[0]->raise_error( 'E_IPADDR_EXPECTED', $ctx )
852             if $_[1] =~ /ip[46]/i;
853              
854             $_[0]->raise_error( 'E_UNEXPECTED_BITMASK', $ctx )
855             if $_[1] =~ /\A(ptr|all|exists|include)\Z/i;
856              
857             $_[0]->_mech_domain_bitmask( '+', $_[1], '@', $_[3] );
858             }
859             ],
860             [#Rule 18
861             'with_bitmask', 4,
862             sub
863             #line 123 "Parser.yp"
864             {
865             my $ctx = $_[1] . $_[2] . '/' . $_[4];
866              
867             $_[0]->raise_error( 'E_IPADDR_EXPECTED', $ctx )
868             if $_[2] =~ /ip[46]/i;
869              
870             $_[0]->raise_error( 'E_UNEXPECTED_BITMASK', $ctx )
871             if $_[2] =~ /\A(ptr|all|exists|include)\Z/i;
872              
873             $_[0]->_mech_domain_bitmask( $_[1], $_[2], '@', $_[4] );
874             }
875             ],
876             [#Rule 19
877             'with_domain_bitmask', 5,
878             sub
879             #line 139 "Parser.yp"
880             {
881             my $ctx = $_[1] . ':' . $_[3] . '/' . $_[5];
882              
883             $_[0]->raise_error( 'E_UNEXPECTED_BITMASK', $ctx )
884             if $_[1] =~ /\A(ptr|all|exists|include)\Z/i;
885              
886             $_[0]->_mech_domain_bitmask( '+', $_[1], $_[3], $_[5] );
887             }
888             ],
889             [#Rule 20
890             'with_domain_bitmask', 6,
891             sub
892             #line 148 "Parser.yp"
893             {
894             my $ctx = $_[1] . $_[2] . ':' . $_[4] . '/' . $_[6];
895              
896             $_[0]->raise_error( 'E_UNEXPECTED_BITMASK', $ctx )
897             if $_[2] =~ /\A(ptr|all|exists|include)\Z/i;
898              
899             $_[0]->_mech_domain_bitmask( $_[1], $_[2], $_[4], $_[6] );
900             }
901             ],
902             [#Rule 21
903             'with_ipaddress', 3,
904             sub
905             #line 161 "Parser.yp"
906             {
907             my $ctx = $_[1] . ':' . $_[3];
908              
909             $_[0]->raise_error( 'E_UNEXPECTED_IPADDR', $ctx )
910             if $_[1] =~ /\A(a|mx|ptr|all|exists|include)\Z/i;
911              
912             $_[0]->_mech_ipaddr_bitmask( '+', $_[1], $_[3], undef );
913             }
914             ],
915             [#Rule 22
916             'with_ipaddress', 4,
917             sub
918             #line 170 "Parser.yp"
919             {
920             my $ctx = $_[1] . $_[2] . ':' . $_[4];
921              
922             $_[0]->raise_error( 'E_UNEXPECTED_IPADDR', $ctx )
923             if $_[2] =~ /\A(a|mx|ptr|all|exists|include)\Z/i;
924              
925             $_[0]->_mech_ipaddr_bitmask( $_[1], $_[2], $_[4], undef );
926             }
927             ],
928             [#Rule 23
929             'with_ipaddress', 5,
930             sub
931             #line 179 "Parser.yp"
932             {
933             my $ctx = $_[1] . ':' . $_[3] . '/' . $_[5];
934              
935             $_[0]->raise_error( 'E_UNEXPECTED_IPADDR', $ctx )
936             if $_[1] =~ /\A(a|mx|ptr|all|exists|include)\Z/i;
937              
938             $_[0]->_mech_ipaddr_bitmask( '+', $_[1], $_[3], $_[5] );
939             }
940             ],
941             [#Rule 24
942             'with_ipaddress', 6,
943             sub
944             #line 188 "Parser.yp"
945             {
946             my $ctx = $_[1] . $_[2] . ':' . $_[4] . '/' . $_[6];
947              
948             $_[0]->raise_error( 'E_UNEXPECTED_IPADDR', $ctx )
949             if $_[2] =~ /\A(a|mx|ptr|all|exists|include)\Z/i;
950              
951             $_[0]->_mech_ipaddr_bitmask( $_[1], $_[2], $_[4], $_[6] );
952             }
953             ]
954             ],
955             @_
956             );
957              
958             bless $self, $class;
959             }
960              
961              
962             #line 198 "Parser.yp"
963              
964              
965             sub parse {
966             my ( $self, $text ) = @_;
967              
968             $input = $self->YYData->{INPUT} = $text;
969             delete $self->YYData->{ERRMSG};
970              
971             return $self->YYParse( yylex => \&_lexer, yyerror => \&_error );
972             }
973              
974             sub error {
975             my ( $self ) = @_;
976             return $self->YYData->{ERRMSG};
977             }
978              
979             sub _build_error {
980             my ( $self, $code, $context, @extra ) = @_;
981              
982             $code = 'E_DEFAULT' unless exists $errors{$code};
983              
984             $self->YYData->{ERRMSG} = {
985             text => sprintf( $errors{$code} => @extra ),
986             code => $code,
987             context => $context,
988             };
989             }
990              
991             sub raise_error {
992             my ( $self, @params ) = @_;
993              
994             $self->_build_error( @params );
995             $self->YYError;
996             }
997              
998             sub _error {
999             my ( $self ) = @_;
1000              
1001             unless ( exists $self->YYData->{ERRMSG} ) {
1002             substr( $input, index( $input, $self->YYCurval ), 0, '<*>' );
1003              
1004             $self->_build_error( 'E_SYNTAX', $input, $self->YYCurval );
1005             }
1006              
1007             return;
1008             }
1009              
1010             sub _lexer {
1011             my ( $parser ) = @_;
1012              
1013             $parser->YYData->{INPUT} =~ s/^\s*//;
1014              
1015             for ( $parser->YYData->{INPUT} ) {
1016             # printf( "[debug] %s\n", $_ );
1017              
1018             s/^(v\=spf\d)\b//i
1019             and return ( 'VERSION', $1 );
1020              
1021             s/^(\/)\b//i
1022             and return ( '/', '/' );
1023             s/^(\:)\b//i
1024             and return ( ':', ':' );
1025             s/^(\=)\b//i
1026             and return ( '=', '=' );
1027              
1028             # qualifiers
1029             s/^([-~\+\?])\b//i
1030             and return ( 'QUALIFIER', $1 );
1031              
1032             # mechanisms
1033             s/^(all|ptr|a|mx|ip4|ip6|exists|include)\b//i
1034             and return ( 'MECHANISM', $1 );
1035              
1036             # modifiers
1037             s/^(redirect|exp)\b//i
1038             and return ( 'MODIFIER', $1 );
1039              
1040             s/^($RE{net}{IPv4}{dec}|$RE{net}{IPv6}{-sep=>':'})\b//i
1041             and return ( 'IPADDRESS', $1 );
1042              
1043             s/^([_\.a-z\d][\-a-z\d]*\.[\.\-a-z\d]*[a-z\d]?)\b//i
1044             and return ( 'DOMAIN', $1 );
1045              
1046             s/^(\d{1,3})\b//i
1047             and return ( 'BITMASK', $1 );
1048              
1049             # garbage
1050             s/^(.+)\b//i
1051             and return ( 'UNKNOWN', $1 );
1052             }
1053              
1054             # EOF
1055             return ( '', undef );
1056             }
1057              
1058             # generic modifier
1059             sub _mod_generic {
1060             my ( $self, $mod, $domain ) = @_;
1061              
1062             return +{
1063             type => 'mod',
1064             modifier => lc $mod,
1065             (
1066             $domain
1067             ? ( domain => $domain ) :
1068             ( )
1069             ),
1070             };
1071             }
1072              
1073             # generic version
1074             sub _ver_generic {
1075             my ( $self, $ver ) = @_;
1076              
1077             return +{
1078             type => 'ver',
1079             version => lc $ver,
1080             };
1081             }
1082              
1083              
1084             # generic mechanism
1085             sub _mech_generic {
1086             my ( $self, $qualifier, $mech, $domain, $ipaddr, $bitmask ) = @_;
1087              
1088             return +{
1089             type => 'mech',
1090             qualifier => $qualifier,
1091             mechanism => lc $mech,
1092             (
1093             $domain
1094             ? ( domain => $domain ) :
1095             ( )
1096             ),
1097             (
1098             $ipaddr
1099             ? ( ( defined $bitmask ? 'network' : 'ipaddress' ) => $ipaddr )
1100             : ( )
1101             ),
1102             (
1103             defined $bitmask
1104             ? ( bitmask => $bitmask )
1105             : ( )
1106             ),
1107             };
1108             }
1109              
1110             sub _mech_domain {
1111             my ( $self, $qualifier, $mech, $domain ) = @_;
1112              
1113             return $self->_mech_generic( $qualifier, $mech, $domain, undef, undef );
1114             }
1115              
1116             sub _mech_domain_bitmask {
1117             my ( $self, $qualifier, $mech, $domain, $bitmask ) = @_;
1118              
1119             return $self->_mech_generic( $qualifier, $mech, $domain, undef, $bitmask );
1120             }
1121              
1122             sub _mech_ipaddr_bitmask {
1123             my ( $self, $qualifier, $mech, $ipaddr, $bitmask ) = @_;
1124              
1125             return $self->_mech_generic( $qualifier, $mech, undef, $ipaddr, $bitmask );
1126             }
1127              
1128             1;
1129              
1130             __END__