Mail-AuthenticationResults-2.20210915/0000775000175000017500000000000014120352241015762 5ustar marcmarcMail-AuthenticationResults-2.20210915/LICENSE0000644000175000017500000004366014120352241016776 0ustar marcmarcThis software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2021 by Marc Bradshaw. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2021 by Marc Bradshaw. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Mail-AuthenticationResults-2.20210915/weaver.ini0000644000175000017500000000054114120352241017752 0ustar marcmarc[@CorePrep] [-SingleEncoding] [Name] [Version] [Region / prelude] [Generic / SYNOPSIS] [Generic / DESCRIPTION] [Generic / OVERVIEW] [Collect / ATTRIBUTES] command = attr [Collect / CONSTRUCTOR] command = constructor [Collect / METHODS] command = method [Collect / FUNCTIONS] command = func [Leftovers] [Region / postlude] [Authors] [Legal] Mail-AuthenticationResults-2.20210915/META.yml0000644000175000017500000000146714120352241017241 0ustar marcmarc--- abstract: 'Object Oriented Authentication-Results Headers' author: - 'Marc Bradshaw ' build_requires: Test::Exception: '0' Test::More: '0' lib: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'Dist::Zilla version 6.017, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Mail-AuthenticationResults requires: Carp: '0' Clone: '0' JSON: '0' Scalar::Util: '0' base: '0' perl: '5.008' strict: '0' warnings: '0' version: '2.20210915' x_contributors: - 'Ricardo Signes ' x_generated_by_perl: v5.34.0 x_serialization_backend: 'YAML::Tiny version 1.73' x_spdx_expression: 'Artistic-1.0-Perl OR GPL-1.0-or-later' Mail-AuthenticationResults-2.20210915/README.md0000644000175000017500000000206214120352241017237 0ustar marcmarc# Mail::AuthenticationResults Object Oriented Authentication-Results Headers [![Code on GitHub](https://img.shields.io/badge/github-repo-blue.svg)](https://github.com/marcbradshaw/Mail-AuthenticationResults) [![Build Status](https://travis-ci.org/marcbradshaw/Mail-AuthenticationResults.svg?branch=master)](https://travis-ci.org/marcbradshaw/Mail-AuthenticationResults) [![Open Issues](https://img.shields.io/github/issues/marcbradshaw/Mail-AuthenticationResults.svg)](https://github.com/marcbradshaw/Mail-AuthenticationResults/issues) [![Dist on CPAN](https://img.shields.io/cpan/v/Mail-AuthenticationResults.svg)](https://metacpan.org/release/Mail-AuthenticationResults) [![CPANTS](https://img.shields.io/badge/cpants-kwalitee-blue.svg)](http://cpants.cpanauthors.org/dist/Mail-AuthenticationResults) # AUTHOR Marc Bradshaw # COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Mail-AuthenticationResults-2.20210915/lib/0000775000175000017500000000000014120352241016530 5ustar marcmarcMail-AuthenticationResults-2.20210915/lib/Mail/0000775000175000017500000000000014120352241017412 5ustar marcmarcMail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults.pm0000644000175000017500000000322614120352241024312 0ustar marcmarcpackage Mail::AuthenticationResults; # ABSTRACT: Object Oriented Authentication-Results Headers require 5.008; use strict; use warnings; our $VERSION = '2.20210915'; # VERSION use Carp; use Mail::AuthenticationResults::Parser; sub new { my ( $class ) = @_; my $self = {}; bless $self, $class; return $self; } sub parser { my ( $self, $auth_headers ) = @_; return Mail::AuthenticationResults::Parser->new( $auth_headers ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Mail::AuthenticationResults - Object Oriented Authentication-Results Headers =head1 VERSION version 2.20210915 =head1 DESCRIPTION Object Oriented Authentication-Results email headers. This parser copes with most styles of Authentication-Results header seen in the wild, but is not yet fully RFC7601 compliant Differences from RFC7601 key/value pairs are parsed when present in the authserv-id section, this is against RFC but has been seen in headers added by Yahoo!. Comments added between key/value pairs will be added after them in the data structures and when stringified. =head1 METHODS =head2 new() Return a new Mail::AuthenticationResults object =head2 parser() Returns a new Mail::AuthenticationResults::Parser object for the supplied $auth_results header =head1 BUGS Please report bugs via the github tracker. https://github.com/marcbradshaw/Mail-AuthenticationResults/issues =head1 AUTHOR Marc Bradshaw =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/0000775000175000017500000000000014120352241023753 5ustar marcmarcMail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/Token/0000775000175000017500000000000014120352241025033 5ustar marcmarcMail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/Token/String.pm0000644000175000017500000000423114120352241026635 0ustar marcmarcpackage Mail::AuthenticationResults::Token::String; # ABSTRACT: Class for modelling AuthenticationResults Header parts detected as strings require 5.008; use strict; use warnings; our $VERSION = '2.20210915'; # VERSION use Carp; use base 'Mail::AuthenticationResults::Token'; sub is { my ( $self ) = @_; return 'string'; } sub parse { my ($self) = @_; my $header = $self->{ 'header' }; my $value = q{}; croak 'Not a string' if $header =~ /^"/; croak 'Not a string' if $header =~ /^\(/; # Parse differently if we are post assignment (we are a value) or not (we are likely a key or key part) my $is_value = 0; my $is_first = 0; if ( exists ( $self->{ 'args' }->{ 'last_non_comment_type' } ) ) { if ( $self->{ 'args' }->{ 'last_non_comment_type' }->is() eq 'assignment' ) { if ( $self->{ 'args' }->{ 'last_non_comment_type' }->value() eq '=' ) { $is_value = 1; } } } else { $is_first = 1; } while ( length $header > 0 ) { my $first = substr( $header,0,1 ); last if $first =~ /\s/; last if $first eq ';'; last if $first eq '"' && ! $is_value && ! $is_first; last if $first eq '(' && ! $is_value && ! $is_first; last if $first eq '=' && ! $is_value && ! $is_first; last if $first eq '/' && ! $is_value && ! $is_first; last if $first eq '.' && ! $is_value && ! $is_first; $value .= $first; $header = substr( $header,1 ); } croak 'Not a string' if $value eq q{}; $self->{ 'value' } = $value; $self->{ 'header' } = $header; return; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Mail::AuthenticationResults::Token::String - Class for modelling AuthenticationResults Header parts detected as strings =head1 VERSION version 2.20210915 =head1 DESCRIPTION Token representing a string =head1 AUTHOR Marc Bradshaw =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/Token/Separator.pm0000644000175000017500000000224414120352241027331 0ustar marcmarcpackage Mail::AuthenticationResults::Token::Separator; # ABSTRACT: Class for modelling AuthenticationResults Header parts detected as separators require 5.008; use strict; use warnings; our $VERSION = '2.20210915'; # VERSION use Carp; use base 'Mail::AuthenticationResults::Token'; sub is { my ( $self ) = @_; return 'separator'; } sub parse { my ($self) = @_; my $header = $self->{ 'header' }; my $value = q{}; my $first = substr( $header,0,1 ); croak 'not a separator' if $first ne ';'; $header = substr( $header,1 ); $self->{ 'value' } = ';'; $self->{ 'header' } = $header; return; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Mail::AuthenticationResults::Token::Separator - Class for modelling AuthenticationResults Header parts detected as separators =head1 VERSION version 2.20210915 =head1 DESCRIPTION Token representing a separator =head1 AUTHOR Marc Bradshaw =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/Token/Space.pm0000644000175000017500000000214614120352241026425 0ustar marcmarcpackage Mail::AuthenticationResults::Token::Space; # ABSTRACT: Class for modelling AuthenticationResults Header parts detected as spaces require 5.008; use strict; use warnings; our $VERSION = '2.20210915'; # VERSION use Carp; use base 'Mail::AuthenticationResults::Token'; sub is { my ( $self ) = @_; return 'space'; } sub new { my ($self) = @_; croak 'Space tokens are not used in parsing'; } sub parse { my ($self) = @_; croak 'Space tokens are not used in parsing'; } sub remainder { my ($self) = @_; croak 'Space tokens are not used in parsing'; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Mail::AuthenticationResults::Token::Space - Class for modelling AuthenticationResults Header parts detected as spaces =head1 VERSION version 2.20210915 =head1 DESCRIPTION Token representing a space =head1 AUTHOR Marc Bradshaw =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/Token/QuotedString.pm0000644000175000017500000000275514120352241030030 0ustar marcmarcpackage Mail::AuthenticationResults::Token::QuotedString; # ABSTRACT: Class for modelling AuthenticationResults Header parts detected as quoted strings require 5.008; use strict; use warnings; our $VERSION = '2.20210915'; # VERSION use Carp; use base 'Mail::AuthenticationResults::Token'; sub is { my ( $self ) = @_; return 'string'; } sub parse { my ($self) = @_; my $header = $self->{ 'header' }; my $value = q{}; my $first = substr( $header,0,1 ); $header = substr( $header,1 ); croak 'not a quoted string' if $first ne '"'; my $closed = 0; while ( length $header > 0 ) { my $first = substr( $header,0,1 ); $header = substr( $header,1 ); if ( $first eq '"' ) { $closed = 1; last; } $value .= $first; } croak 'Quoted string not closed' if ! $closed; $self->{ 'value' } = $value; $self->{ 'header' } = $header; return; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Mail::AuthenticationResults::Token::QuotedString - Class for modelling AuthenticationResults Header parts detected as quoted strings =head1 VERSION version 2.20210915 =head1 DESCRIPTION Token representing a quoted string =head1 AUTHOR Marc Bradshaw =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/Token/Comment.pm0000644000175000017500000000312114120352241026766 0ustar marcmarcpackage Mail::AuthenticationResults::Token::Comment; # ABSTRACT: Class for modelling AuthenticationResults Header parts detected as comments require 5.008; use strict; use warnings; our $VERSION = '2.20210915'; # VERSION use Carp; use base 'Mail::AuthenticationResults::Token'; sub is { my ( $self ) = @_; return 'comment'; } sub parse { my ($self) = @_; my $header = $self->{ 'header' }; my $value = q{}; my $depth = 0; my $first = substr( $header,0,1 ); if ( $first ne '(' ) { croak 'Not a comment'; } while ( length $header > 0 ) { my $first = substr( $header,0,1 ); $header = substr( $header,1 ); $value .= $first; if ( $first eq '(' ) { $depth++; } elsif ( $first eq ')' ) { $depth--; last if $depth == 0; } } if ( $depth != 0 ) { croak 'Mismatched parens in comment'; } $value =~ s/^\(//; $value =~ s/\)$//; $self->{ 'value' } = $value; $self->{ 'header' } = $header; return; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Mail::AuthenticationResults::Token::Comment - Class for modelling AuthenticationResults Header parts detected as comments =head1 VERSION version 2.20210915 =head1 DESCRIPTION Token representing a comment =head1 AUTHOR Marc Bradshaw =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/Token/Assignment.pm0000644000175000017500000000235714120352241027506 0ustar marcmarcpackage Mail::AuthenticationResults::Token::Assignment; # ABSTRACT: Class for modelling AuthenticationResults Header parts detected as assignments require 5.008; use strict; use warnings; our $VERSION = '2.20210915'; # VERSION use Carp; use base 'Mail::AuthenticationResults::Token'; sub is { my ( $self ) = @_; return 'assignment'; } sub parse { my ($self) = @_; my $header = $self->{ 'header' }; my $value = q{}; my $first = substr( $header,0,1 ); if ( $first ne '=' && $first ne '.' && $first ne '/' ) { croak 'not an assignment'; } $header = substr( $header,1 ); $self->{ 'value' } = $first; $self->{ 'header' } = $header; return; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Mail::AuthenticationResults::Token::Assignment - Class for modelling AuthenticationResults Header parts detected as assignments =head1 VERSION version 2.20210915 =head1 DESCRIPTION Token representing an assignment operator =head1 AUTHOR Marc Bradshaw =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/Token.pm0000644000175000017500000000461014120352241025370 0ustar marcmarcpackage Mail::AuthenticationResults::Token; # ABSTRACT: Base class for modelling AuthenticationResults Header parts require 5.008; use strict; use warnings; our $VERSION = '2.20210915'; # VERSION use Carp; sub new { my ( $class, $header, $args ) = @_; my $self = { 'args' => $args }; bless $self, $class; $self->{ 'header' } = $header; $self->parse(); return $self; } sub new_from_value { my ( $class, $value ) = @_; my $self = { 'value' => $value }; bless $self, $class; return $self; } sub value { my ( $self ) = @_; return $self->{ 'value' }; } sub remainder { my ( $self ) = @_; return $self->{ 'header' }; } sub parse { my ( $self ) = @_; croak 'parse not implemented'; } sub is { # uncoverable subroutine # a base Token cannot be instantiated, and all subclasses should implement this method. my ( $self ) = @_; # uncoverable statement croak 'is not implemented'; # uncoverable statement } 1;; __END__ =pod =encoding UTF-8 =head1 NAME Mail::AuthenticationResults::Token - Base class for modelling AuthenticationResults Header parts =head1 VERSION version 2.20210915 =head1 DESCRIPTION Classes representing a tokenised Authentication Results Header, used in parsing =head1 METHODS =head2 new( $header, $args ) Return a new Token object parsed from the given $header string using $args $args value depend on the subclass of Token used, possible types are L an assignment operator L a comment L a quoted string L a separator L a string =head2 new_from_value( $value ) Create a new token from the given value =head2 value() Return the value of the current Token instance. =head2 remainder() Return the remainder of the header string after parsing the current token out. =head2 parse() Run the parser on the current $header and set up value() and remainder(). =head2 is() Return the type of token we are. =head1 AUTHOR Marc Bradshaw =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/FoldableHeader.pm0000644000175000017500000002173114120352241027134 0ustar marcmarcpackage Mail::AuthenticationResults::FoldableHeader; # ABSTRACT: Class for modelling a foldable header string require 5.008; use strict; use warnings; our $VERSION = '2.20210915'; # VERSION use Carp; use Mail::AuthenticationResults::Token::String; use Mail::AuthenticationResults::Token::Space; use Mail::AuthenticationResults::Token::Separator; use Mail::AuthenticationResults::Token::Comment; use Mail::AuthenticationResults::Token::Assignment; sub new { my ( $class, $args ) = @_; my $self = {}; bless $self, $class; $self->{ 'string' } = []; return $self; } sub eol { my ( $self ) = @_; return $self->{ 'eol' } if exists ( $self->{ 'eol' } ); return "\n"; } sub set_eol { my ( $self, $eol ) = @_; $self->{ 'eol' } = $eol; return $self; } sub indent { my ( $self ) = @_; return $self->{ 'indent' } if exists ( $self->{ 'indent' } ); return ' '; } sub set_indent { my ( $self, $indent ) = @_; $self->{ 'indent' } = $indent; return $self; } sub sub_indent { my ( $self ) = @_; return $self->{ 'sub_indent' } if exists ( $self->{ 'sub_indent' } ); return ' '; } sub set_sub_indent { my ( $self, $indent ) = @_; $self->{ 'sub_indent' } = $indent; return $self; } sub try_fold_at { my ( $self ) = @_; return $self->{ 'try_fold_at' } if exists ( $self->{ 'try_fold_at' } ); return 800; } sub set_try_fold_at { my ( $self, $length ) = @_; $self->{ 'try_fold_at' } = $length; return $self; } sub force_fold_at { my ( $self ) = @_; return $self->{ 'force_fold_at' } if exists ( $self->{ 'force_fold_at' } ); return 900; } sub set_force_fold_at { my ( $self, $length ) = @_; $self->{ 'force_fold_at' } = $length; return $self; } sub string { my( $self, $string ) = @_; push @{ $self->{ 'string' } }, Mail::AuthenticationResults::Token::String->new_from_value( $string ); return $self; } sub space { my ( $self, $string ) = @_; push @{ $self->{ 'string' } }, Mail::AuthenticationResults::Token::Space->new_from_value( $string ); return $self; } sub separator { my ( $self, $string ) = @_; push @{ $self->{ 'string' } }, Mail::AuthenticationResults::Token::Separator->new_from_value( $string ); return $self; } sub comment { my ( $self, $string ) = @_; push @{ $self->{ 'string' } }, Mail::AuthenticationResults::Token::Comment->new_from_value( $string ); return $self; } sub assignment { my ( $self, $string ) = @_; push @{ $self->{ 'string' } }, Mail::AuthenticationResults::Token::Assignment->new_from_value( $string ); return $self; } sub as_string { my ( $self ) = @_; my $string = q{}; my $string_length = 0; my $content_added = 0; my $sections = []; my $stack = []; my $last_type; foreach my $part ( @{ $self->{ 'string' } } ) { if ( $part->is() eq 'space' && $last_type ne 'space' ) { # We have a folding space push @$sections, $stack if @$stack; $stack = []; } push @$stack, $part; $last_type = $part->is(); } push @$sections, $stack if @$stack; my $eol = $self->eol();; my $indent = $self->indent(); my $sub_indent = $self->sub_indent(); my $fold_length = 0; SECTION: while ( my $section = shift @$sections ) { if ( $section->[0]->is() eq 'space' && $section->[0]->value() eq $eol ) { # This section starts a new line $fold_length = 0; if ( ! exists( $section->[0]->{ '_folded' } ) ) { if ( $section->[1]->is() eq 'space' ) { # Take the last indent value for the fold indent $indent = $section->[1]->value(); } } } my $section_string = join( q{}, map { $_->value() } @$section ); my $section_length = length( $section_string ); if ( $fold_length + $section_length > $self->try_fold_at() ) { if ( $fold_length > 0 ) { # Remove whitespace tokens at beginning of section while ( $section->[0]->is() eq 'space' ) { shift @$section; } # Insert new folding whitespace at beginning of section unshift @$section, Mail::AuthenticationResults::Token::Space->new_from_value( $indent . $sub_indent ); unshift @$section, Mail::AuthenticationResults::Token::Space->new_from_value( $eol ); $section->[0]->{ '_folded' } = 1; unshift @$sections, $section; next SECTION; } else { # ToDo: # This section alone is over the line limit # It already starts with a fold, so we need to remove # some of it to a new line if we can. # Strategy 1: Fold at a relevant token boundary my $first_section = []; my $second_section = []; push @$second_section, Mail::AuthenticationResults::Token::Space->new_from_value( $eol ); push @$second_section, Mail::AuthenticationResults::Token::Space->new_from_value( $indent . $sub_indent ); $second_section->[0]->{ '_folded' } = 1; my $first_section_length = 0; foreach my $part ( @$section ) { my $part_length = length $part->value(); if ( $part_length + $first_section_length < $self->try_fold_at() ) { push @$first_section, $part; $first_section_length += $part_length; } else { push @$second_section, $part; $first_section_length = $self->try_fold_at() + 1; # everything from this point goes onto second } } # Do we have a first and second section with actual content? if ( ( grep { $_->is() ne 'space' } @$first_section ) && ( grep { $_->is() ne 'space' } @$second_section ) ) { unshift @$sections, $second_section; unshift @$sections, $first_section; next SECTION; } # We MUST fold at $self->force_fold_at(); # Strategy 2: Force fold at a space within a string # Strategy 3: Force fold anywhere # We assume that force fold is greater than try fold } } $string .= $section_string; $fold_length += $section_length; } return $string; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Mail::AuthenticationResults::FoldableHeader - Class for modelling a foldable header string =head1 VERSION version 2.20210915 =head1 DESCRIPTION Class representing a foldable Authentication Results header string =head1 METHODS =head2 new( $args ) Return a new instance of this class =head2 eol() Return the current eol marker. =head2 set_eol( $eol ) Set the current eol marker. =head2 indent() Return the current base indent string. Defaults to 4 spaces. =head2 set_indent( $indent ) Set the current base indent string. =head2 sub_indent() Return the current fold indent string. This is added to the current indent for folded headers. Defaults to 2 spaces. =head2 set_sub_indent( $indent ) Set the current fold indent string. =head2 try_fold_at() Return the length of header line for triggering a fold attempt =head2 set_try_fold_at( $length ) Set the length of header line for triggering a fold attempt. Defaults to 800. =head2 force_fold_at() Return the length of header line for forcing a fold. =head2 set_force_fold_at( $length ) Set the length of header line for forcing a fold. Defaults to 900. =head2 string( $string ) Add $string to this header string In this context, string can include a quoted string, or a string with assignment operators embedded within it. A string is a unit of data which we do not want to break with a fold. =head2 space( $string ) Add a space $string to this header string In this context, a space can be a single space, multiple spaces, or a folding space. A space is a unit of data which would be an ideal spot to insert a fold. =head2 separator( $string ) Add a separator $string to this header string In this context, a separator is the ; string or the / string. =head2 comment( $string ) Add a comment $string to this header string In this context, a comment is a comment string. A comment is a unit of data which we do not want to break with a fold. =head2 assignment( $string ) Add an assignment $string to this header string In this context, as assignment is the = string. =head2 as_string() Return the current header string =head1 AUTHOR Marc Bradshaw =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/Header/0000775000175000017500000000000014120352241025143 5ustar marcmarcMail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/Header/Base.pm0000644000175000017500000003603614120352241026361 0ustar marcmarcpackage Mail::AuthenticationResults::Header::Base; # ABSTRACT: Base class for modelling parts of the Authentication Results Header require 5.008; use strict; use warnings; our $VERSION = '2.20210915'; # VERSION use Scalar::Util qw{ weaken refaddr }; use JSON; use Carp; use Clone qw{ clone }; use Mail::AuthenticationResults::Header::Group; use Mail::AuthenticationResults::FoldableHeader; sub _HAS_KEY{ return 0; } sub _HAS_VALUE{ return 0; } sub _HAS_CHILDREN{ return 0; } sub _ALLOWED_CHILDREN{ # uncoverable subroutine # does not run in Base as HAS_CHILDREN returns 0 return 0; # uncoverable statement } sub new { my ( $class ) = @_; my $self = {}; bless $self, $class; return $self; } sub set_key { my ( $self, $key ) = @_; croak 'Does not have key' if ! $self->_HAS_KEY(); croak 'Key cannot be undefined' if ! defined $key; croak 'Key cannot be empty' if $key eq q{}; croak 'Invalid characters in key' if $key =~ /"/; croak 'Invalid characters in key' if $key =~ /\n/; croak 'Invalid characters in key' if $key =~ /\r/; $self->{ 'key' } = $key; return $self; } sub key { my ( $self ) = @_; croak 'Does not have key' if ! $self->_HAS_KEY(); return q{} if ! defined $self->{ 'key' }; #5.8 return $self->{ 'key' }; } sub safe_set_value { my ( $self, $value ) = @_; $value = q{} if ! defined $value; $value =~ s/\t/ /g; $value =~ s/\n/ /g; $value =~ s/\r/ /g; $value =~ s/\(/ /g; $value =~ s/\)/ /g; $value =~ s/\\/ /g; $value =~ s/"/ /g; $value =~ s/;/ /g; $value =~ s/^\s+//; $value =~ s/\s+$//; #$value =~ s/ /_/g; $self->set_value( $value ); return $self; } sub set_value { my ( $self, $value ) = @_; croak 'Does not have value' if ! $self->_HAS_VALUE(); croak 'Value cannot be undefined' if ! defined $value; #croak 'Value cannot be empty' if $value eq q{}; croak 'Invalid characters in value' if $value =~ /"/; croak 'Invalid characters in value' if $value =~ /\n/; croak 'Invalid characters in value' if $value =~ /\r/; $self->{ 'value' } = $value; return $self; } sub value { my ( $self ) = @_; croak 'Does not have value' if ! $self->_HAS_VALUE(); return q{} if ! defined $self->{ 'value' }; # 5.8 return $self->{ 'value' }; } sub stringify { my ( $self, $value ) = @_; my $string = $value; $string = q{} if ! defined $string; #5.8; if ( $string =~ /[\s\t \(\);=]/ ) { $string = '"' . $string . '"'; } return $string; } sub children { my ( $self ) = @_; croak 'Does not have children' if ! $self->_HAS_CHILDREN(); return [] if ! defined $self->{ 'children' }; #5.8 return $self->{ 'children' }; } sub orphan { my ( $self, $parent ) = @_; croak 'Child does not have a parent' if ! exists $self->{ 'parent' }; delete $self->{ 'parent' }; return; } sub copy_children_from { my ( $self, $object ) = @_; for my $original_entry (@{$object->children()}) { my $entry = clone $original_entry; $entry->orphan if exists $entry->{ 'parent' };; $self->add_child( $entry ); } } sub add_parent { my ( $self, $parent ) = @_; return if ( ref $parent eq 'Mail::AuthenticationResults::Header::Group' ); croak 'Child already has a parent' if exists $self->{ 'parent' }; croak 'Cannot add parent' if ! $parent->_ALLOWED_CHILDREN( $self ); # uncoverable branch true # Does not run as test is also done in add_child before add_parent is called. $self->{ 'parent' } = $parent; weaken $self->{ 'parent' }; return; } sub parent { my ( $self ) = @_; return $self->{ 'parent' }; } sub remove_child { my ( $self, $child ) = @_; croak 'Does not have children' if ! $self->_HAS_CHILDREN(); croak 'Cannot add child' if ! $self->_ALLOWED_CHILDREN( $child ); croak 'Cannot add a class as its own parent' if refaddr $self == refaddr $child; # uncoverable branch true # Does not run as there are no ALLOWED_CHILDREN results which permit this my @children; my $child_removed = 0; foreach my $mychild ( @{ $self->{ 'children' } } ) { if ( refaddr $child == refaddr $mychild ) { if ( ref $self ne 'Mail::AuthenticationResults::Header::Group' ) { $child->orphan(); } $child_removed = 1; } else { push @children, $mychild; } } my $children = $self->{ 'children' }; croak 'Not a child of this class' if ! $child_removed; $self->{ 'children' } = \@children; return $self; } sub add_child { my ( $self, $child ) = @_; croak 'Does not have children' if ! $self->_HAS_CHILDREN(); croak 'Cannot add child' if ! $self->_ALLOWED_CHILDREN( $child ); croak 'Cannot add a class as its own parent' if refaddr $self == refaddr $child; # uncoverable branch true # Does not run as there are no ALLOWED_CHILDREN results which permit this $child->add_parent( $self ); push @{ $self->{ 'children' } }, $child; return $child; } sub ancestor { my ( $self ) = @_; my $depth = 0; my $ancestor = $self->parent(); my $eldest = $self; while ( defined $ancestor ) { $eldest = $ancestor; $ancestor = $ancestor->parent(); $depth++; } return ( $eldest, $depth ); } sub as_string_prefix { my ( $self, $header ) = @_; my ( $eldest, $depth ) = $self->ancestor(); my $indents = 1; if ( $eldest->can( 'indent_by' ) ) { $indents = $eldest->indent_by(); } my $eol = "\n"; if ( $eldest->can( 'eol' ) ) { $eol = $eldest->eol(); } my $indent = ' '; my $added = 0; if ( $eldest->can( 'indent_on' ) ) { if ( $eldest->indent_on( ref $self ) ) { $header->space( $eol ); $header->space( ' ' x ( $indents * $depth ) ); $added = 1; } } $header->space( ' ' ) if ! $added; return $indent; } sub _as_hashref { my ( $self ) = @_; my $type = lc ref $self; $type =~ s/^(.*::)//; my $hashref = { 'type' => $type }; $hashref->{'key'} = $self->key() if $self->_HAS_KEY(); $hashref->{'value'} = $self->value() if $self->_HAS_VALUE(); if ( $self->_HAS_CHILDREN() ) { my @children = map { $_->_as_hashref() } @{ $self->children() }; $hashref->{'children'} = \@children; } return $hashref; } sub as_json { my ( $self ) = @_; my $J = JSON->new(); $J->canonical(); return $J->encode( $self->_as_hashref() ); } sub as_string { my ( $self ) = @_; my $header = Mail::AuthenticationResults::FoldableHeader->new(); $self->build_string( $header ); return $header->as_string(); } sub build_string { my ( $self, $header ) = @_; if ( ! $self->key() ) { return; } $header->string( $self->stringify( $self->key() ) ); if ( $self->value() ) { $header->assignment( '=' ); $header->string( $self->stringify( $self->value() ) ); } elsif ( $self->value() eq '0' ) { $header->assignment( '=' ); $header->string( '0' ); } elsif ( $self->value() eq q{} ) { # special case none here if ( $self->key() ne 'none' ) { $header->assignment( '=' ); $header->string( '""' ); } } if ( $self->_HAS_CHILDREN() ) { # uncoverable branch false # There are no classes which run this code without having children foreach my $child ( @{$self->children()} ) { $child->as_string_prefix( $header ); $child->build_string( $header ); } } return; } sub search { my ( $self, $search ) = @_; my $group = Mail::AuthenticationResults::Header::Group->new(); my $match = 1; if ( exists( $search->{ 'key' } ) ) { if ( $self->_HAS_KEY() ) { if ( ref $search->{ 'key' } eq 'Regexp' && $self->key() =~ m/$search->{'key'}/ ) { $match = $match && 1; # uncoverable statement # $match is always 1 at this point, left this way for consistency } elsif ( lc $search->{ 'key' } eq lc $self->key() ) { $match = $match && 1; # uncoverable statement # $match is always 1 at this point, left this way for consistency } else { $match = 0; } } else { $match = 0; } } if ( exists( $search->{ 'value' } ) ) { $search->{ 'value' } = '' if ! defined $search->{ 'value' }; if ( $self->_HAS_VALUE() ) { if ( ref $search->{ 'value' } eq 'Regexp' && $self->value() =~ m/$search->{'value'}/ ) { $match = $match && 1; } elsif ( lc $search->{ 'value' } eq lc $self->value() ) { $match = $match && 1; } else { $match = 0; } } else { $match = 0; # uncoverable statement # There are no code paths with the current classes which end up here } } if ( exists( $search->{ 'authserv_id' } ) ) { if ( $self->_HAS_VALUE() ) { if ( lc ref $self eq 'mail::authenticationresults::header' ) { my $authserv_id = eval{ $self->value()->value() } || q{}; if ( ref $search->{ 'authserv_id' } eq 'Regexp' && $authserv_id =~ m/$search->{'authserv_id'}/ ) { $match = $match && 1; } elsif ( lc $search->{ 'authserv_id' } eq lc $authserv_id ) { $match = $match && 1; } else { $match = 0; } } else { $match = 0; } } else { $match = 0; # uncoverable statement # There are no code paths with the current classes which end up here } } if ( exists( $search->{ 'isa' } ) ) { if ( lc ref $self eq 'mail::authenticationresults::header::' . lc $search->{ 'isa' } ) { $match = $match && 1; } elsif ( lc ref $self eq 'mail::authenticationresults::header' && lc $search->{ 'isa' } eq 'header' ) { $match = $match && 1; } else { $match = 0; } } if ( exists( $search->{ 'has' } ) ) { foreach my $query ( @{ $search->{ 'has' } } ) { $match = 0 if ( scalar @{ $self->search( $query )->children() } == 0 ); } } if ( $match ) { $group->add_child( $self ); } if ( $self->_HAS_CHILDREN() ) { foreach my $child ( @{$self->children()} ) { my $childfound = $child->search( $search ); if ( scalar @{ $childfound->children() } ) { $group->add_child( $childfound ); } } } return $group; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Mail::AuthenticationResults::Header::Base - Base class for modelling parts of the Authentication Results Header =head1 VERSION version 2.20210915 =head1 DESCRIPTION Set of classes representing the various parts and sub parts of Authentication Results Headers. =over =item * L represents a complete Authentication Results Header set =item * L represents the AuthServID part of the set =item * L represents a comment =item * L represents a main entry =item * L represents a group of parts, typically as a search result =item * L represents a sub entry part =item * L represents a version part =back Header AuthServID Version Comment SubEntry Entry Comment Entry Comment SubEntry Comment Entry SubEntry SubEntry Group Entry Comment SubEntry Comment Entry SubEntry =head1 METHODS =head2 new() Return a new instance of this class =head2 set_key( $key ) Set the key for this instance. Croaks if $key is invalid. =head2 key() Return the current key for this instance. Croaks if this instance type can not have a key. =head2 safe_set_value( $value ) Set the value for this instance. Munges the value to remove invalid characters before setting. This method also removes some value characters when their inclusion would be likely to break simple parsers. =head2 set_value( $value ) Set the value for this instance. Croaks if the value contains invalid characters. =head2 value() Returns the current value for this instance. =head2 stringify( $value ) Returns $value with stringify rules applied. =head2 children() Returns a listref of this instances children. Croaks if this instance type can not have children. =head2 orphan() Removes the parent for this instance. Croaks if this instance does not have a parent. =head2 copy_children_from( $object ) Copy (clone) all of the children from the given object into this object. =head2 add_parent( $parent ) Sets the parent for this instance to the supplied object. Croaks if the relationship between $parent and $self is not valid. =head2 parent() Returns the parent object for this instance. =head2 remove_child( $child ) Removes $child as a child of this instance. Croaks if the relationship between $child and $self is not valid. =head2 add_child( $child ) Adds $child as a child of this instance. Croaks if the relationship between $child and $self is not valid. =head2 ancestor() Returns the top Header object and depth of this child =head2 as_string_prefix( $header ) Add the prefix to as_string for this object when calledas a child of another objects as_string method call. =head2 as_json() Return this instance as a JSON serialised string =head2 as_string() Returns this instance as a string. =head2 build_string( $header ) Build a string using the supplied Mail::AuthenticationResults::FoldableHeader object. =head2 search( $search ) Apply search rules in $search to this instance and return a Mail::AuthenticationResults::Header::Group object containing the matches. $search is a HASHREF with the following possible key/value pairs =over =item key Match if the instance key matches the supplied value (string or regex) =item value Match if the instance value matches the supplied value (string or regex) =item isa Match is the instance class typs matches the supplied value. This is a lowercase version of the class type, (comment,entry,subentry,etc)) =item has An arrayref of searches, match this class if the supplied search queries would return at least 1 result each =back =head1 AUTHOR Marc Bradshaw =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/Header/Group.pm0000644000175000017500000000501214120352241026571 0ustar marcmarcpackage Mail::AuthenticationResults::Header::Group; # ABSTRACT: Class modelling Groups of Authentication Results Header parts require 5.008; use strict; use warnings; our $VERSION = '2.20210915'; # VERSION use Scalar::Util qw{ refaddr }; use Carp; use base 'Mail::AuthenticationResults::Header::Base'; sub _HAS_CHILDREN{ return 1; } sub _ALLOWED_CHILDREN { my ( $self, $child ) = @_; return 1 if ref $child eq 'Mail::AuthenticationResults::Header'; return 1 if ref $child eq 'Mail::AuthenticationResults::Header::AuthServID'; return 1 if ref $child eq 'Mail::AuthenticationResults::Header::Comment'; return 1 if ref $child eq 'Mail::AuthenticationResults::Header::Entry'; return 1 if ref $child eq 'Mail::AuthenticationResults::Header::Group'; return 1 if ref $child eq 'Mail::AuthenticationResults::Header::SubEntry'; return 1 if ref $child eq 'Mail::AuthenticationResults::Header::Version'; return 0; } sub add_child { my ( $self, $child ) = @_; croak 'Cannot add child' if ! $self->_ALLOWED_CHILDREN( $child ); croak 'Cannot add a class as its own parent' if refaddr $self == refaddr $child; if ( ref $child eq 'Mail::AuthenticationResults::Header::Group' ) { foreach my $subchild ( @{ $child->children() } ) { $self->add_child( $subchild ); } ## ToDo what to return in this case? } else { foreach my $current_child ( @{ $self->children() } ) { if ( $current_child == $child ) { return $child; } } $self->SUPER::add_child( $child ); } return $child; } sub build_string { my ( $self, $header ) = @_; my $sep = 0; foreach my $child ( @{ $self->children() } ) { $header->separator( ';' ) if $sep; $header->space( "\n" ) if $sep; $sep = 1; $child->build_string( $header ); } return; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Mail::AuthenticationResults::Header::Group - Class modelling Groups of Authentication Results Header parts =head1 VERSION version 2.20210915 =head1 DESCRIPTION A group of classes, typically returned as a search results set, and should include all required parts. Please see L =head1 AUTHOR Marc Bradshaw =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/Header/AuthServID.pm0000644000175000017500000000373614120352241027466 0ustar marcmarcpackage Mail::AuthenticationResults::Header::AuthServID; # ABSTRACT: Class modelling the AuthServID part of the Authentication Results Headerr require 5.008; use strict; use warnings; our $VERSION = '2.20210915'; # VERSION use Carp; use base 'Mail::AuthenticationResults::Header::Base'; sub _HAS_VALUE{ return 1; } sub _HAS_CHILDREN{ return 1; } sub _ALLOWED_CHILDREN { my ( $self, $child ) = @_; return 1 if ref $child eq 'Mail::AuthenticationResults::Header::Comment'; return 1 if ref $child eq 'Mail::AuthenticationResults::Header::SubEntry'; return 1 if ref $child eq 'Mail::AuthenticationResults::Header::Version'; return 0; } sub build_string { my ( $self, $header ) = @_; $header->string( $self->stringify( $self->value() ) ); foreach my $child ( @{ $self->children() } ) { $header->space( ' ' ); #$header->concat( $child->as_string_prefix() ); $child->build_string( $header ); } return; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Mail::AuthenticationResults::Header::AuthServID - Class modelling the AuthServID part of the Authentication Results Headerr =head1 VERSION version 2.20210915 =head1 DESCRIPTION The AuthServID is typically the first section of an Authentication Results Header, it records the server responsible for performing the Authentication Results checks, and can additionally hold a version number (assumed to be 1 if not present). Some providers also add additional sub entries to the field, hence this class is capable of being a parent to version, comment, and sub entry types. This class is set as the value for a Mail::AuthenticationResults::Header class. Please see L =head1 AUTHOR Marc Bradshaw =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/Header/Entry.pm0000644000175000017500000000275014120352241026604 0ustar marcmarcpackage Mail::AuthenticationResults::Header::Entry; # ABSTRACT: Class modelling Main Entry parts of the Authentication Results Header require 5.008; use strict; use warnings; our $VERSION = '2.20210915'; # VERSION use Scalar::Util qw{ refaddr }; use Carp; use base 'Mail::AuthenticationResults::Header::Base'; sub _HAS_KEY{ return 1; } sub _HAS_VALUE{ return 1; } sub _HAS_CHILDREN{ return 1; } sub _ALLOWED_CHILDREN { my ( $self, $child ) = @_; return 1 if ref $child eq 'Mail::AuthenticationResults::Header::Comment'; return 1 if ref $child eq 'Mail::AuthenticationResults::Header::SubEntry'; return 1 if ref $child eq 'Mail::AuthenticationResults::Header::Version'; return 0; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Mail::AuthenticationResults::Header::Entry - Class modelling Main Entry parts of the Authentication Results Header =head1 VERSION version 2.20210915 =head1 DESCRIPTION Entries are the main result of an Authentication Resutls check, an example of this would be "dkim=pass" or "dmarc=fail", there may be additional comments of sub entries associated with this entry, these are represented as children of this class. Please see L =head1 AUTHOR Marc Bradshaw =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/Header/Comment.pm0000644000175000017500000000467314120352241027113 0ustar marcmarcpackage Mail::AuthenticationResults::Header::Comment; # ABSTRACT: Class modelling Comment parts of the Authentication Results Header require 5.008; use strict; use warnings; our $VERSION = '2.20210915'; # VERSION use Scalar::Util qw{ weaken }; use Carp; use base 'Mail::AuthenticationResults::Header::Base'; sub _HAS_VALUE{ return 1; } sub safe_set_value { my ( $self, $value ) = @_; $value = q{} if ! defined $value; $value =~ s/\t/ /g; $value =~ s/\n/ /g; $value =~ s/\r/ /g; my $remain = $value; my $depth = 0; my $nested_ok = 1; while ( length $remain > 0 ) { my $first = substr( $remain,0,1 ); $remain = substr( $remain,1 ); $depth++ if $first eq '('; $depth-- if $first eq ')'; $nested_ok = 0 if $depth == -1; } $nested_ok = 0 if $depth != 0; # Remove parens if nested comments would be broken by them. if ( ! $nested_ok ) { $value =~ s/\(/ /g; $value =~ s/\)/ /g; } $value =~ s/^\s+//; $value =~ s/\s+$//; #$value =~ s/;/ /g; $self->set_value( $value ); return $self; } sub set_value { my ( $self, $value ) = @_; my $remain = $value; my $depth = 0; while ( length $remain > 0 ) { my $first = substr( $remain,0,1 ); $remain = substr( $remain,1 ); $depth++ if $first eq '('; $depth-- if $first eq ')'; croak 'Out of order parens in comment' if $depth == -1; } croak 'Mismatched parens in comment' if $depth != 0; croak 'Invalid characters in value' if $value =~ /\n/; croak 'Invalid characters in value' if $value =~ /\r/; $self->{ 'value' } = $value; return $self; } sub build_string { my ( $self, $header ) = @_; $header->comment( '(' . $self->value() . ')' ); return; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Mail::AuthenticationResults::Header::Comment - Class modelling Comment parts of the Authentication Results Header =head1 VERSION version 2.20210915 =head1 DESCRIPTION Comments may be associated with many parts of the Authentication Results set, this class represents a comment. Please see L =head1 AUTHOR Marc Bradshaw =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/Header/SubEntry.pm0000644000175000017500000000254314120352241027256 0ustar marcmarcpackage Mail::AuthenticationResults::Header::SubEntry; # ABSTRACT: Class modelling Sub Entry parts of the Authentication Results Header require 5.008; use strict; use warnings; our $VERSION = '2.20210915'; # VERSION use Carp; use base 'Mail::AuthenticationResults::Header::Base'; sub _HAS_KEY{ return 1; } sub _HAS_VALUE{ return 1; } sub _HAS_CHILDREN{ return 1; } sub _ALLOWED_CHILDREN { my ( $self, $child ) = @_; return 1 if ref $child eq 'Mail::AuthenticationResults::Header::Comment'; return 1 if ref $child eq 'Mail::AuthenticationResults::Header::Version'; return 0; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Mail::AuthenticationResults::Header::SubEntry - Class modelling Sub Entry parts of the Authentication Results Header =head1 VERSION version 2.20210915 =head1 DESCRIPTION A sub entry is a result which relates to a main entry class, for example if the main entry is "dkim=pass" then the sub entry may be "domain.d=example.com" There may be comments associated with the subentry as children. Please see L =head1 AUTHOR Marc Bradshaw =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/Header/Version.pm0000644000175000017500000000350414120352241027126 0ustar marcmarcpackage Mail::AuthenticationResults::Header::Version; # ABSTRACT: Class modelling the AuthServID part of the Authentication Results Header require 5.008; use strict; use warnings; our $VERSION = '2.20210915'; # VERSION use Scalar::Util qw{ weaken }; use Carp; use base 'Mail::AuthenticationResults::Header::Base'; sub _HAS_VALUE{ return 1; } sub build_string { my ( $self, $header ) = @_; if ( ! $self->value() ) { return; } if ( ref $self->parent() ne 'Mail::AuthenticationResults::Header::AuthServID' ) { $header->separator( '/' ); $header->space( ' ' ); } $header->string( $self->value() ); return; } sub safe_set_value { my ( $self, $value ) = @_; $value = 1 if ! defined $value; $value =~ s/[^0-9]//g; $value = 1 if $value eq q{}; $self->set_value( $value ); return $self; } sub set_value { my ( $self, $value ) = @_; croak 'Does not have value' if ! $self->_HAS_VALUE(); # uncoverable branch true # HAS_VALUE is 1 for this class croak 'Value cannot be undefined' if ! defined $value; croak 'Value must be numeric' if $value =~ /[^0-9]/; $self->{ 'value' } = $value; return $self; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Mail::AuthenticationResults::Header::Version - Class modelling the AuthServID part of the Authentication Results Header =head1 VERSION version 2.20210915 =head1 DESCRIPTION A version string, this may be associated with an AuthServID, Entry, Group, or SubEntry. Please see L =head1 AUTHOR Marc Bradshaw =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/Header.pm0000644000175000017500000001743314120352241025507 0ustar marcmarcpackage Mail::AuthenticationResults::Header; # ABSTRACT: Class modelling the Entire Authentication Results Header set require 5.008; use strict; use warnings; our $VERSION = '2.20210915'; # VERSION use Carp; use Mail::AuthenticationResults::Header::AuthServID; use base 'Mail::AuthenticationResults::Header::Base'; sub _HAS_VALUE{ return 1; } sub _HAS_CHILDREN{ return 1; } sub _ALLOWED_CHILDREN { my ( $self, $child ) = @_; return 1 if ref $child eq 'Mail::AuthenticationResults::Header::Comment'; return 1 if ref $child eq 'Mail::AuthenticationResults::Header::Entry'; return 0; } sub set_indent_by { my ( $self, $value ) = @_; $self->{ 'indent_by' } = $value; return $self; } sub indent_by { my ( $self ) = @_; return 4 if ! defined $self->{ 'indent_by' }; #5.8 return $self->{ 'indent_by'}; } sub set_indent_on { my ( $self, $type ) = @_; $self->{ 'indent_type_' . $type } = 1; return $self; } sub clear_indent_on { my ( $self, $type ) = @_; $self->{ 'indent_type_' . $type } = 0; return $self; } sub indent_on { my ( $self, $type ) = @_; if ( $type eq 'Mail::AuthenticationResults::Header::Entry' ) { return 1 if ! defined $self->{ 'indent_type_' . $type }; #5.8 return $self->{ 'indent_type_' . $type }; } if ( $type eq 'Mail::AuthenticationResults::Header::SubEntry' ) { return 0 if ! defined $self->{ 'indent_type_' . $type }; #5.8 return $self->{ 'indent_type_' . $type }; } elsif ( $type eq 'Mail::AuthenticationResults::Header::Comment' ) { return 0 if ! defined $self->{ 'indent_type_' . $type }; #5.8 return $self->{ 'indent_type_' . $type }; } return 0; } sub set_eol { my ( $self, $eol ) = @_; if ( $eol =~ /^\r?\n$/ ) { $self->{ 'eol' } = $eol; } else { croak 'Invalid eol string'; } return $self; } sub eol { my ( $self ) = @_; return "\n" if ! defined $self->{ 'eol' }; #5.8 return $self->{ 'eol' }; } sub fold_at { my ( $self ) = @_; return $self->{ 'fold_at' }; } sub set_fold_at { my ( $self, $fold_at ) = @_; $self->{ 'fold_at' } = $fold_at; return $self; } sub force_fold_at { my ( $self ) = @_; return $self->{ 'force_fold_at' }; } sub set_force_fold_at { my ( $self, $fold_at ) = @_; $self->{ 'force_fold_at' } = $fold_at; return $self; } sub set_indent_style { my ( $self, $style ) = @_; if ( $style eq 'none' ) { $self->clear_indent_on( 'Mail::AuthenticationResults::Header::Entry' ); $self->clear_indent_on( 'Mail::AuthenticationResults::Header::SubEntry' ); $self->clear_indent_on( 'Mail::AuthenticationResults::Header::Comment' ); } elsif ( $style eq 'entry' ) { $self->set_indent_by( 4 ); $self->set_indent_on( 'Mail::AuthenticationResults::Header::Entry' ); $self->clear_indent_on( 'Mail::AuthenticationResults::Header::SubEntry' ); $self->clear_indent_on( 'Mail::AuthenticationResults::Header::Comment' ); } elsif ( $style eq 'subentry' ) { $self->set_indent_by( 4 ); $self->set_indent_on( 'Mail::AuthenticationResults::Header::Entry' ); $self->set_indent_on( 'Mail::AuthenticationResults::Header::SubEntry' ); $self->clear_indent_on( 'Mail::AuthenticationResults::Header::Comment' ); } elsif ( $style eq 'full' ) { $self->set_indent_by( 4 ); $self->set_indent_on( 'Mail::AuthenticationResults::Header::Entry' ); $self->set_indent_on( 'Mail::AuthenticationResults::Header::SubEntry' ); $self->set_indent_on( 'Mail::AuthenticationResults::Header::Comment' ); } else { croak "Unknown indent style $style"; } return $self; } sub safe_set_value { my ( $self, $value ) = @_; $self->set_value( $value ); return $self; } sub set_value { my ( $self, $value ) = @_; croak 'Does not have value' if ! $self->_HAS_VALUE(); # uncoverable branch true # HAS_VALUE is 1 for this class croak 'Value cannot be undefined' if ! defined $value; croak 'value should be an AuthServID type' if ref $value ne 'Mail::AuthenticationResults::Header::AuthServID'; $self->{ 'value' } = $value; return $self; } sub add_parent { my ( $self, $parent ) = @_; return; } sub add_child { my ( $self, $child ) = @_; croak 'Cannot add a SubEntry as a child of a Header' if ref $child eq 'Mail::AuthenticationResults::Header::SubEntry'; return $self->SUPER::add_child( $child ); } sub _as_hashref { my ( $self ) = @_; my $type = lc ref $self; $type =~ s/^(.*::)//; my $hashref = { 'type' => $type }; $hashref->{'key'} = $self->key() if $self->_HAS_KEY(); $hashref->{'authserv_id'} = $self->value()->_as_hashref() if $self->value(); if ( $self->_HAS_CHILDREN() ) { my @children = map { $_->_as_hashref() } @{ $self->children() }; $hashref->{'children'} = \@children; } return $hashref; } sub as_string { my ( $self ) = @_; my $header = Mail::AuthenticationResults::FoldableHeader->new(); $header->set_try_fold_at( $self->fold_at() ) if defined $self->fold_at(); $header->set_force_fold_at( $self->force_fold_at() ) if defined $self->force_fold_at(); $header->set_eol( $self->eol() ); $header->set_indent( ' ' x $self->indent_by() ); $header->set_sub_indent( ' ' ); $self->build_string( $header ); return $header->as_string(); } sub build_string { my ( $self, $header ) = @_; my $value = q{}; if ( $self->value() ) { $self->value()->build_string( $header ); } else { $header->string( 'unknown' ); } $header->separator( ';' ); my $sep = 0; foreach my $child ( @{ $self->children() } ) { $header->separator( ';' ) if $sep; $sep = 1; $child->as_string_prefix( $header ); $child->build_string( $header ); } if ( scalar @{ $self->search({ 'isa' => 'entry' } )->children() } == 0 ) { #if ( scalar @{ $self->children() } > 0 ) { # $value .= ' '; #} $header->space( ' ' ); $header->string ( 'none' ); } return; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Mail::AuthenticationResults::Header - Class modelling the Entire Authentication Results Header set =head1 VERSION version 2.20210915 =head1 DESCRIPTION This class represents the main Authentication Results set Please see L =head1 METHODS =head2 set_indent_by( $value ) Number of spaces to indent by for as_string() =head2 indent_by() Return the number of spaces for as_string() to indent by =head2 set_indent_on( $class ) The given class will be indented =head2 clear_indent_on( $class ) The given class will not be indented =head2 indent_on( $class ) Should the given class be indented =head2 set_eol( $eol ) Set the eol style for as_string =head2 eol() Return the current eol style =head2 fold_at() Return the current fold at value if set Strings will be folded if longer than this value where possible. =head2 set_fold_at( $fold_at ) set the current fold_at value for as_string Strings will be folded if longer than this value where possible. =head2 force_fold_at() Return the current force fold at value if set Strings WILL be folded if longer than this value. =head2 set_force_fold_at( $fold_at ) set the current force_fold_at value for as_string Strings WILL be folded if longer than this value. =head2 set_indent_style( $style ) Set the as_string indenting style Options are none, entry, subentry, full =head1 AUTHOR Marc Bradshaw =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mail-AuthenticationResults-2.20210915/lib/Mail/AuthenticationResults/Parser.pm0000644000175000017500000002473414120352241025555 0ustar marcmarcpackage Mail::AuthenticationResults::Parser; # ABSTRACT: Class for parsing Authentication Results Headers require 5.008; use strict; use warnings; our $VERSION = '2.20210915'; # VERSION use Carp; use Mail::AuthenticationResults::Header; use Mail::AuthenticationResults::Header::AuthServID; use Mail::AuthenticationResults::Header::Comment; use Mail::AuthenticationResults::Header::Entry; use Mail::AuthenticationResults::Header::SubEntry; use Mail::AuthenticationResults::Header::Version; use Mail::AuthenticationResults::Token::Assignment; use Mail::AuthenticationResults::Token::Comment; use Mail::AuthenticationResults::Token::QuotedString; use Mail::AuthenticationResults::Token::Separator; use Mail::AuthenticationResults::Token::String; sub new { my ( $class, $auth_header ) = @_; my $self = {}; bless $self, $class; if ( $auth_header ) { $self->parse( $auth_header ); } return $self; } sub parse { my ( $self, $header ) = @_; $self->tokenise( $header ); $self->_parse_authservid(); while ( @{ $self->{ 'tokenised' } } ) { $self->_parse_entry(); } return $self->parsed(); } sub tokenise { my ( $self, $header ) = @_; my @tokenised; $header =~ s/\n/ /g; $header =~ s/\r/ /g; $header =~ s/^\s+//; # Remove Header part if present if ( $header =~ /^Authentication-Results:/i ) { $header =~ s/^Authentication-Results://i; } my $args = {}; while ( length($header) > 0 ) { my $token; $header =~ s/^\s+//; my $last_non_comment_type = exists( $args->{ 'last_non_comment_type' } ) ? $args->{ 'last_non_comment_type' }->is() : 'none'; if ( length( $header ) == 0 ) { last; } elsif ( $header =~ /^\(/ ) { $token = Mail::AuthenticationResults::Token::Comment->new( $header, $args ); } elsif ( $header =~ /^;/ ) { $token = Mail::AuthenticationResults::Token::Separator->new( $header, $args ); $args->{ 'last_non_comment_type' } = $token; } elsif ( $header =~ /^"/ ) { $token = Mail::AuthenticationResults::Token::QuotedString->new( $header, $args ); $args->{ 'last_non_comment_type' } = $token; } elsif ( $last_non_comment_type ne 'assignment' && $header =~ /^\./ ) { $token = Mail::AuthenticationResults::Token::Assignment->new( $header, $args ); $args->{ 'last_non_comment_type' } = $token; } elsif ( $last_non_comment_type eq 'assignment' && $header =~ /^\./ ) { # a . after an assignment cannot be another assignment, likely an unquoted string. $token = Mail::AuthenticationResults::Token::String->new( $header, $args ); $args->{ 'last_non_comment_type' } = $token; } elsif ( $header =~ /^\// ) { $token = Mail::AuthenticationResults::Token::Assignment->new( $header, $args ); $args->{ 'last_non_comment_type' } = $token; } elsif ( $header =~ /^=/ ) { $token = Mail::AuthenticationResults::Token::Assignment->new( $header, $args ); $args->{ 'last_non_comment_type' } = $token; } else { $token = Mail::AuthenticationResults::Token::String->new( $header, $args ); $args->{ 'last_non_comment_type' } = $token; } $header = $token->remainder(); push @tokenised, $token; } croak 'Nothing to parse' if ! @tokenised; $self->{ 'tokenised' } = \@tokenised; return; } sub _parse_authservid { my ( $self ) = @_; my $tokenised = $self->{ 'tokenised' }; my $token; my $authserv_id = Mail::AuthenticationResults::Header::AuthServID->new(); # Find the ServID while ( @$tokenised ) { $token = shift @$tokenised; if ( $token->is() eq 'string' ) { $authserv_id->set_value( $token->value() ); last; } elsif ( $token->is() eq 'comment' ) { $authserv_id->add_child( Mail::AuthenticationResults::Header::Comment->new()->set_value( $token->value() ) ); } else { # assignment or separator, both are bogus croak 'Invalid AuthServ-ID'; } } my $expecting = 'key'; my $key; TOKEN: while ( @$tokenised ) { $token = shift @$tokenised; if ( $token->is() eq 'assignment' ) { if ( $expecting eq 'assignment' ) { if ( $token->value() eq '=' ) { $expecting = 'value'; } else { croak 'unexpected token'; } } else { croak 'not expecting an assignment'; } } elsif ( $token->is() eq 'comment' ) { $authserv_id->add_child( Mail::AuthenticationResults::Header::Comment->new()->set_value( $token->value() ) ); } elsif ( $token->is() eq 'separator' ) { last TOKEN; } if ( $token->is() eq 'string' ) { if ( $expecting eq 'key' ) { $key = $token; $expecting = 'assignment'; } elsif ( $expecting eq 'value' ) { $authserv_id->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( $key->value() )->set_value( $token->value() ) ); $expecting = 'key'; undef $key; } else { croak 'not expecting a string'; } } } if ( $expecting ne 'key' ) { if ( $key->value() =~ /^[0-9]+$/ ) { # Looks like a version $authserv_id->add_child( Mail::AuthenticationResults::Header::Version->new()->set_value( $key->value() ) ); } else { # Probably bogus, but who knows! $authserv_id->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( $key->value() ) ); } } $self->{ 'header' } = Mail::AuthenticationResults::Header->new()->set_value( $authserv_id ); $self->{ 'tokenised' } = $tokenised; return; } sub _parse_entry { my ( $self ) = @_; my $tokenised = $self->{ 'tokenised' }; my $entry = Mail::AuthenticationResults::Header::Entry->new(); my $working_on = $entry; my $expecting = 'key'; my $is_subentry = 0; TOKEN: while ( @$tokenised ) { my $token = shift @$tokenised; if ( $token->is() eq 'assignment' ) { if ( $expecting eq 'assignment' ) { if ( $token->value() eq '=' ) { $expecting = 'value'; } elsif ( $token->value() eq '.' ) { $expecting = 'keymod'; } elsif ( $token->value() eq '/' ) { $expecting = 'version'; } } else { croak 'not expecting an assignment'; } } elsif ( $token->is() eq 'comment' ) { $working_on->add_child( Mail::AuthenticationResults::Header::Comment->new()->set_value( $token->value() ) ); } elsif ( $token->is() eq 'separator' ) { last TOKEN; } if ( $token->is() eq 'string' ) { if ( $expecting eq 'key' ) { if ( ! $is_subentry ) { if ( $token->value() eq 'none' ) { # Special case the none $expecting = 'no_more_after_none'; } else { $entry->set_key( $token->value() ); $expecting = 'assignment'; } } else { $working_on = Mail::AuthenticationResults::Header::SubEntry->new()->set_key( $token->value() ); $expecting = 'assignment'; } } elsif ( $expecting eq 'keymod' ) { $working_on->set_key( $working_on->key() . '.' . $token->value() ); $expecting = 'assignment'; } elsif ( $expecting eq 'version' ) { if ( $token->value() =~ /^[0-9]+$/ ) { # Looks like a version $working_on->add_child( Mail::AuthenticationResults::Header::Version->new()->set_value( $token->value() ) ); } else { croak 'bad version token'; } $expecting = 'assignment'; } elsif ( $expecting eq 'value' ) { if ( ! $is_subentry ) { $entry->set_value( $token->value() ); $is_subentry = 1; } else { $entry->add_child( $working_on->set_value( $token->value() ) ); } $expecting = 'key'; } else { croak 'not expecting a string'; } } } if ( $expecting eq 'no_more_after_none' ) { $self->{ 'tokenised' } = $tokenised; # We may have comment entries, if so add those to the header object foreach my $child ( @{ $entry->children() } ) { delete $child->{ 'parent' }; $self->{ 'header' }->add_child( $child ); } return; } if ( $expecting ne 'key' ) { if ( $is_subentry ) { $entry->add_child( $working_on ); } } $self->{ 'header' }->add_child( $entry ); $self->{ 'tokenised' } = $tokenised; return; } sub parsed { my ( $self ) = @_; return $self->{ 'header' }; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Mail::AuthenticationResults::Parser - Class for parsing Authentication Results Headers =head1 VERSION version 2.20210915 =head1 DESCRIPTION Class for parsing Authentication Results headers into objects. takes a string and returns a L object =head1 METHODS =head2 new( $header ) Return a new Parser instance. If $header is supplied then parse it and return the parsed object. =head2 parse( $header ) Parse $header and return the parsed object. =head2 tokenise( $header ) Tokenise the given $header string =head2 parsed() Return the parsed object tree =head1 AUTHOR Marc Bradshaw =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mail-AuthenticationResults-2.20210915/README0000644000175000017500000000227114120352241016642 0ustar marcmarcNAME Mail::AuthenticationResults - Object Oriented Authentication-Results Headers VERSION version 2.20210915 DESCRIPTION Object Oriented Authentication-Results email headers. This parser copes with most styles of Authentication-Results header seen in the wild, but is not yet fully RFC7601 compliant Differences from RFC7601 key/value pairs are parsed when present in the authserv-id section, this is against RFC but has been seen in headers added by Yahoo!. Comments added between key/value pairs will be added after them in the data structures and when stringified. METHODS new() Return a new Mail::AuthenticationResults object parser() Returns a new Mail::AuthenticationResults::Parser object for the supplied $auth_results header BUGS Please report bugs via the github tracker. https://github.com/marcbradshaw/Mail-AuthenticationResults/issues AUTHOR Marc Bradshaw COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Marc Bradshaw. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Mail-AuthenticationResults-2.20210915/Changes0000644000175000017500000000336314120352241017260 0ustar marcmarcChange log for Mail::AuthenticationResults 2.20210915 2021-09-15 11:10:20+00:00 UTC - Fix for older versions of Perl 2.20210914 2021-09-14 05:17:31+00:00 UTC - New method to copy children from 1 object to another 2.20210112 2021-01-12 22:10:28+00:00 UTC - Switch to a purely numeric version string 1.20200824.1 2020-08-24 01:03:58+00:00 UTC - Fix some POD formatting 1.20200331.1 2020-03-31 03:31:13+00:00 UTC - Treat an undefined value as emptystring in search 1.20200108 2020-01-08 03:38:09+00:00 UTC - Added as_json method to return structured JSON version of an instance. - Properly parse strings beginning with a . 1.20180923 2018-09-23 13:39:01+10:00 Australia/Melbourne - Added a 'has' search property to allow searching for results whose children match a given search. - Add a header 'isa' type to search for top level header entries within a group. - Add an 'authserv_id' search type to search for headers from a given authserv-id within a group. 1.20180518 2018-05-18 10:10:03+10:00 Australia/Melbourne - Consider CR properly when parsing an entry. 1.20180328 2018-03-28 21:35:34+11:00 Australia/Melbourne - Folding of headers rendered as string for the Mail::AuthenticationResults::Header object. 1.20180314 2018-03-14 - Correctly stringify zero - Method to remove chindren from an instance 1.20180215 2018-02-15 - Perl 5.8 compatability 1.20180211 2018-02-11 - Test improvements - Coverage improvements - Stringify and validation improvements 1.20180113 2018-01-13 - Added safe set methods - General improvements 1.20171230 2017-12-30 - Improve test suite - Add search method - Improve parser 1.20171226 2017-12-26 - First Release, Module for handing Authentication-Results headers. Mail-AuthenticationResults-2.20210915/MANIFEST0000644000175000017500000000301614120352241017111 0ustar marcmarc# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.017. Changes LICENSE MANIFEST META.yml Makefile.PL README README.md dist.ini lib/Mail/AuthenticationResults.pm lib/Mail/AuthenticationResults/FoldableHeader.pm lib/Mail/AuthenticationResults/Header.pm lib/Mail/AuthenticationResults/Header/AuthServID.pm lib/Mail/AuthenticationResults/Header/Base.pm lib/Mail/AuthenticationResults/Header/Comment.pm lib/Mail/AuthenticationResults/Header/Entry.pm lib/Mail/AuthenticationResults/Header/Group.pm lib/Mail/AuthenticationResults/Header/SubEntry.pm lib/Mail/AuthenticationResults/Header/Version.pm lib/Mail/AuthenticationResults/Parser.pm lib/Mail/AuthenticationResults/Token.pm lib/Mail/AuthenticationResults/Token/Assignment.pm lib/Mail/AuthenticationResults/Token/Comment.pm lib/Mail/AuthenticationResults/Token/QuotedString.pm lib/Mail/AuthenticationResults/Token/Separator.pm lib/Mail/AuthenticationResults/Token/Space.pm lib/Mail/AuthenticationResults/Token/String.pm t/02-children.t t/02-comment.t t/02-get.t t/02-none.t t/02-parser-begin-dot.t t/02-parser-quoted.t t/02-parser.t t/02-safe_set.t t/02-set.t t/02-tokens.t t/03-add-children-from.t t/03-parser-bogus.t t/03-parser.t t/03-search-authserv-id.t t/03-search-has.t t/03-search.t t/04-aol.t t/04-fastmail.t t/04-gmail.t t/04-icloud.t t/04-mail.ru.t t/04-outlook.t t/04-yahoo.t t/04-yandex.t t/05-as-json.t t/05-as_string-styles.t t/05-as_string-wrap.t t/05-eol.t t/05-parser-comment-heavy.t t/author-critic.t t/author-pod-coverage.t t/author-pod-syntax.t weaver.ini Mail-AuthenticationResults-2.20210915/t/0000775000175000017500000000000014120352241016225 5ustar marcmarcMail-AuthenticationResults-2.20210915/t/02-children.t0000644000175000017500000002726214120352241020430 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Header; use Mail::AuthenticationResults::Header::AuthServID; use Mail::AuthenticationResults::Header::Base; use Mail::AuthenticationResults::Header::Comment; use Mail::AuthenticationResults::Header::Entry; use Mail::AuthenticationResults::Header::Group; use Mail::AuthenticationResults::Header::SubEntry; use Mail::AuthenticationResults::Header::Version; my ( $Header, $Base, $Comment, $Entry, $Group, $SubEntry, $AuthServID, $Version ); my ( $Header2, $Base2, $Comment2, $Entry2, $Group2, $SubEntry2, $AuthServID2, $Version2 ); sub setup { $Header = Mail::AuthenticationResults::Header->new(); $Base = Mail::AuthenticationResults::Header::Base->new(); $Comment = Mail::AuthenticationResults::Header::Comment->new(); $Entry = Mail::AuthenticationResults::Header::Entry->new(); $Group = Mail::AuthenticationResults::Header::Group->new(); $SubEntry = Mail::AuthenticationResults::Header::SubEntry->new(); $AuthServID = Mail::AuthenticationResults::Header::AuthServID->new(); $Version = Mail::AuthenticationResults::Header::Version->new(); $Header2 = Mail::AuthenticationResults::Header->new(); $Base2 = Mail::AuthenticationResults::Header::Base->new(); $Comment2 = Mail::AuthenticationResults::Header::Comment->new(); $Entry2 = Mail::AuthenticationResults::Header::Entry->new(); $Group2 = Mail::AuthenticationResults::Header::Group->new(); $SubEntry2 = Mail::AuthenticationResults::Header::SubEntry->new(); $AuthServID2 = Mail::AuthenticationResults::Header::AuthServID->new(); $Version2 = Mail::AuthenticationResults::Header::Version->new(); } subtest 'orphan' => sub{ setup(); dies_ok( sub{ $Header->orphan() }, 'Cannot orphan Header' ); dies_ok( sub{ $Base->orphan() }, 'Cannot orphan Header' ); dies_ok( sub{ $Comment->orphan() }, 'Cannot orphan Header' ); dies_ok( sub{ $Entry->orphan() }, 'Cannot orphan Header' ); dies_ok( sub{ $Group->orphan() }, 'Cannot orphan Header' ); dies_ok( sub{ $Header->orphan() }, 'Cannot orphan Header' ); dies_ok( sub{ $Header->orphan() }, 'Cannot orphan Header' ); dies_ok( sub{ $Header->orphan() }, 'Cannot orphan Header' ); }; subtest 'self' => sub{ setup(); dies_ok( sub{ $Header->add_child( $Header ) }, 'Header Header self dies' ); dies_ok( sub{ $Base->add_child( $Base ) }, 'Base Base self dies' ); dies_ok( sub{ $Comment->add_child( $Comment ) }, 'Comment Comment self dies' ); dies_ok( sub{ $Entry->add_child( $Entry ) }, 'Entry Entry self dies' ); dies_ok( sub{ $Group->add_child( $Group ) }, 'Group Group self dies' ); dies_ok( sub{ $SubEntry->add_child( $SubEntry ) }, 'SubEntry SubEntry self dies' ); dies_ok( sub{ $AuthServID->add_child( $AuthServID ) }, 'AuthServID AuthServID self dies' ); dies_ok( sub{ $Version->add_child( $Version ) }, 'Version Version self dies' ); }; subtest 'self type' => sub{ setup(); dies_ok( sub{ $Header->add_child( $Header2 ) }, 'Header Header dies' ); dies_ok( sub{ $Header->add_child( $Base2 ) }, 'Header Base dies' ); lives_ok( sub{ $Header->add_child( $Comment2 ) }, 'Header Comment lives' ); lives_ok( sub{ $Header->add_child( $Entry2 ) }, 'Header Entry lives' ); dies_ok( sub{ $Header->add_child( $Group2 ) }, 'Header Group dies' ); dies_ok( sub{ $Header->add_child( $Entry2 ) }, 'Header Entry repeat dies' ); dies_ok( sub{ $Header->add_child( $SubEntry2 ) }, 'Header SubEntry dies' ); dies_ok( sub{ $Header->add_child( $AuthServID) }, 'Header AuthServID dies' ); dies_ok( sub{ $Header->add_child( $Version ) }, 'Header Version dies' ); lives_ok( sub{ $Header->remove_child( $Comment2 ) }, 'Header Comment remove lives' ); lives_ok( sub{ $Header->remove_child( $Entry2 ) }, 'Header Entry remove lives' ); lives_ok( sub{ $Header->add_child( $Comment2 ) }, 'Header Comment lives' ); lives_ok( sub{ $Header->add_child( $Entry2 ) }, 'Header Entry lives' ); }; subtest 'base' => sub{ setup(); dies_ok( sub{ $Base->add_child( $Header2 ) }, 'Base Header dies' ); dies_ok( sub{ $Base->add_child( $Base2 ) }, 'Base Base dies' ); dies_ok( sub{ $Base->add_child( $Comment2 ) }, 'Base Comment dies' ); dies_ok( sub{ $Base->add_child( $Entry2 ) }, 'Base Entry dies' ); dies_ok( sub{ $Base->add_child( $Group2 ) }, 'Base Group dies' ); dies_ok( sub{ $Base->add_child( $SubEntry2 ) }, 'Base SubEntry dies' ); dies_ok( sub{ $Base->add_child( $AuthServID) }, 'Base AuthServID dies' ); dies_ok( sub{ $Base->add_child( $Version ) }, 'Base Version dies' ); }; subtest 'comment' => sub{ setup(); dies_ok( sub{ $Comment->add_child( $Header2 ) }, 'Comment Header dies' ); dies_ok( sub{ $Comment->add_child( $Base2 ) }, 'Comment Base dies' ); dies_ok( sub{ $Comment->add_child( $Comment2 ) }, 'Comment Comment dies' ); dies_ok( sub{ $Comment->add_child( $Entry2 ) }, 'Comment Entry dies' ); dies_ok( sub{ $Comment->add_child( $Group2 ) }, 'Comment Group dies' ); dies_ok( sub{ $Comment->add_child( $SubEntry2 ) }, 'Comment SubEntry dies' ); dies_ok( sub{ $Comment->add_child( $AuthServID) }, 'Comment AuthServID dies' ); dies_ok( sub{ $Comment->add_child( $Version ) }, 'Comment Version dies' ); }; subtest 'entry' => sub{ setup(); dies_ok( sub{ $Entry->add_child( $Header2 ) }, 'Entry Header dies' ); dies_ok( sub{ $Entry->add_child( $Base2 ) }, 'Entry Base dies' ); lives_ok( sub{ $Entry->add_child( $Comment2 ) }, 'Entry Comment lives' ); dies_ok( sub{ $Entry->add_child( $Comment2 ) }, 'Entry Comment repeat dies' ); dies_ok( sub{ $Entry->add_child( $Entry2 ) }, 'Entry Entry dies' ); dies_ok( sub{ $Entry->add_child( $Group2 ) }, 'Entry Group dies' ); lives_ok( sub{ $Entry->add_child( $SubEntry2 ) }, 'Entry SubEntry lives' ); dies_ok( sub{ $Entry->add_child( $AuthServID) }, 'Entry AuthServID dies' ); lives_ok( sub{ $Entry->add_child( $Version ) }, 'Entry Version lives' ); lives_ok( sub{ $Entry->remove_child( $Comment2 ) }, 'Entry Comment remove lives' ); lives_ok( sub{ $Entry->remove_child( $SubEntry2 ) }, 'Entry SubEntry remove lives' ); lives_ok( sub{ $Entry->remove_child( $Version ) }, 'Entry Version remove lives' ); lives_ok( sub{ $Entry->add_child( $Comment2 ) }, 'Entry Comment lives' ); lives_ok( sub{ $Entry->add_child( $SubEntry2 ) }, 'Entry SubEntry lives' ); lives_ok( sub{ $Entry->add_child( $Version ) }, 'Entry Version lives' ); }; subtest 'group' => sub{ setup(); lives_ok( sub{ $Group->add_child( $Header2 ) }, 'Group Header lives' ); dies_ok( sub{ $Group->add_child( $Base2 ) }, 'Group Base dies' ); lives_ok( sub{ $Group->add_child( $Comment2 ) }, 'Group Comment lives' ); lives_ok( sub{ $Group->add_child( $Entry2 ) }, 'Group Entry lives' ); lives_ok( sub{ $Group->add_child( $Group2 ) }, 'Group Group lives' ); lives_ok( sub{ $Group->add_child( $SubEntry2 ) }, 'Group SubEntry lives' ); lives_ok( sub{ $Group->add_child( $AuthServID) }, 'Group AuthServID lives' ); lives_ok( sub{ $Group->add_child( $Version ) }, 'Group Version lives' ); # Group repeats should not die, but should not result in duplicates is( scalar @{$Group->children()}, 6, 'Has 6 children' ); lives_ok( sub{ $Group->add_child( $Header2 ) }, 'Group Header repeat lives' ); lives_ok( sub{ $Group->add_child( $Comment2 ) }, 'Group Comment repeat lives' ); lives_ok( sub{ $Group->add_child( $Entry2 ) }, 'Group Entry repeat lives' ); lives_ok( sub{ $Group->add_child( $Group2 ) }, 'Group Group repeat lives' ); lives_ok( sub{ $Group->add_child( $SubEntry2 ) }, 'Group SubEntry repeat lives' ); lives_ok( sub{ $Group->add_child( $AuthServID) }, 'Group AuthServID repeat lives' ); lives_ok( sub{ $Group->add_child( $Version ) }, 'Group Version repeat lives' ); is( scalar @{$Group->children()}, 6, 'Still has 6 children' ); lives_ok( sub{ $Group->remove_child( $Header2 ) }, 'Group Header remove lives' ); lives_ok( sub{ $Group->remove_child( $Comment2 ) }, 'Group Comment remove lives' ); lives_ok( sub{ $Group->remove_child( $Entry2 ) }, 'Group Entry remove lives' ); lives_ok( sub{ $Group->remove_child( $SubEntry2 ) }, 'Group SubEntry remove lives' ); lives_ok( sub{ $Group->remove_child( $AuthServID) }, 'Group AuthServID remove lives' ); lives_ok( sub{ $Group->remove_child( $Version ) }, 'Group Version remove lives' ); is( scalar @{$Group->children()}, 0, 'Now has 0 children' ); }; subtest 'subentry' => sub{ setup(); dies_ok( sub{ $SubEntry->add_child( $Header2 ) }, 'SubEntry Header dies' ); dies_ok( sub{ $SubEntry->add_child( $Base2 ) }, 'SubEntry Base dies' ); lives_ok( sub{ $SubEntry->add_child( $Comment2 ) }, 'SubEntry Comment lives' ); dies_ok( sub{ $SubEntry->add_child( $Comment2 ) }, 'SubEntry Comment repeat dies' ); dies_ok( sub{ $SubEntry->add_child( $Entry2 ) }, 'SubEntry Entry dies' ); dies_ok( sub{ $SubEntry->add_child( $Group2 ) }, 'SubEntry Group dies' ); dies_ok( sub{ $SubEntry->add_child( $SubEntry2 ) }, 'SubEntry SubEntry dies' ); dies_ok( sub{ $SubEntry->add_child( $AuthServID) }, 'SubEntry AuthServID dies' ); lives_ok( sub{ $SubEntry->add_child( $Version ) }, 'SubEntry Version lives' ); lives_ok( sub{ $SubEntry->remove_child( $Comment2 ) }, 'SubEntry Comment remove lives' ); lives_ok( sub{ $SubEntry->remove_child( $Version ) }, 'SubEntry Version remove lives' ); lives_ok( sub{ $SubEntry->add_child( $Comment2 ) }, 'SubEntry Comment lives' ); lives_ok( sub{ $SubEntry->add_child( $Version ) }, 'SubEntry Version lives' ); }; subtest 'authservid' => sub{ setup(); dies_ok( sub{ $AuthServID->add_child( $Header2 ) }, 'AuthServID Header dies' ); dies_ok( sub{ $AuthServID->add_child( $Base2 ) }, 'AuthServID Base dies' ); lives_ok( sub{ $AuthServID->add_child( $Comment2 ) }, 'AuthServID Comment lives' ); dies_ok( sub{ $AuthServID->add_child( $Comment2 ) }, 'AuthServID Comment repeat dies' ); dies_ok( sub{ $AuthServID->add_child( $Entry2 ) }, 'AuthServID Entry dies' ); dies_ok( sub{ $AuthServID->add_child( $Group2 ) }, 'AuthServID Group dies' ); lives_ok( sub{ $AuthServID->add_child( $SubEntry2 ) }, 'AuthServID SubEntry lives' ); dies_ok( sub{ $AuthServID->add_child( $AuthServID) }, 'AuthServID AuthServID dies' ); lives_ok( sub{ $AuthServID->add_child( $Version ) }, 'AuthServID Version lives' ); lives_ok( sub{ $AuthServID->remove_child( $Comment2 ) }, 'AuthServID Comment remove lives' ); lives_ok( sub{ $AuthServID->remove_child( $SubEntry2 ) }, 'AuthServID SubEntry remove lives' ); lives_ok( sub{ $AuthServID->remove_child( $Version ) }, 'AuthServID Version remove lives' ); lives_ok( sub{ $AuthServID->add_child( $Comment2 ) }, 'AuthServID Comment lives' ); lives_ok( sub{ $AuthServID->add_child( $SubEntry2 ) }, 'AuthServID SubEntry lives' ); lives_ok( sub{ $AuthServID->add_child( $Version ) }, 'AuthServID Version lives' ); }; subtest 'version' => sub{ setup(); dies_ok( sub{ $Version->add_child( $Header2 ) }, 'Version Header dies' ); dies_ok( sub{ $Version->add_child( $Base2 ) }, 'Version Base dies' ); dies_ok( sub{ $Version->add_child( $Comment2 ) }, 'Version Comment dies' ); dies_ok( sub{ $Version->add_child( $Comment2 ) }, 'Version Comment repeat dies' ); dies_ok( sub{ $Version->add_child( $Entry2 ) }, 'Version Entry dies' ); dies_ok( sub{ $Version->add_child( $Group2 ) }, 'Version Group dies' ); dies_ok( sub{ $Version->add_child( $SubEntry2 ) }, 'Version SubEntry dies' ); dies_ok( sub{ $Version->add_child( $AuthServID) }, 'Version AuthServID dies' ); dies_ok( sub{ $Version->add_child( $Version ) }, 'Version Version dies' ); }; done_testing(); Mail-AuthenticationResults-2.20210915/t/author-pod-syntax.t0000644000175000017500000000045414120352241022021 0ustar marcmarc#!perl BEGIN { unless ($ENV{AUTHOR_TESTING}) { print qq{1..0 # SKIP these tests are for testing by the author\n}; exit } } # This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. use strict; use warnings; use Test::More; use Test::Pod 1.41; all_pod_files_ok(); Mail-AuthenticationResults-2.20210915/t/02-get.t0000644000175000017500000000472514120352241017416 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Header; use Mail::AuthenticationResults::Header::Base; use Mail::AuthenticationResults::Header::Comment; use Mail::AuthenticationResults::Header::Entry; use Mail::AuthenticationResults::Header::Group; use Mail::AuthenticationResults::Header::SubEntry; use Mail::AuthenticationResults::Header::Version; use Mail::AuthenticationResults::Header::AuthServID; my $Base = Mail::AuthenticationResults::Header::Base->new(); my $Comment = Mail::AuthenticationResults::Header::Comment->new(); my $Entry = Mail::AuthenticationResults::Header::Entry->new(); my $Group = Mail::AuthenticationResults::Header::Group->new(); my $Header = Mail::AuthenticationResults::Header->new(); my $SubEntry = Mail::AuthenticationResults::Header::SubEntry->new(); my $Version = Mail::AuthenticationResults::Header::Version->new(); my $AuthServID = Mail::AuthenticationResults::Header::AuthServID->new(); #test_get( $Base ); subtest 'comment' => sub{ test_get( $Comment ); is ( $Comment->as_string(), '()', 'Comment stringifies as expected' ); }; subtest 'entry' => sub{ test_get( $Entry ); is ( $Entry->as_string(), '', 'Entry stringifies as expected' ); }; subtest 'group' => sub{ test_get( $Group ); is ( $Group->as_string(), '', 'Group stringifies as expected' ); }; subtest 'header' => sub{ test_get( $Header ); is ( $Header->as_string(), "unknown; none", 'Header stringifies as expected' ); }; subtest 'subentry' => sub{ test_get( $SubEntry ); is ( $SubEntry->as_string(), '', 'SubEntrystringifies as expected' ); }; subtest 'version' => sub{ test_get( $Version ); is ( $Version->as_string(), '', 'Version stringifies as expected' ); }; subtest 'authservid' => sub{ test_get( $AuthServID ); is ( $AuthServID->as_string(), '', 'AuthServID stringifies as expected' ); }; sub test_get { my ( $class ) = @_; is ( $class->stringify(), q{}, 'Null stringifies correctly' ); if ( $class->_HAS_KEY() ) { is ( $class->key(), q{}, ( ref $class ) . ' key returns empty string' ); } else { dies_ok( sub{ $class->key() }, ( ref $class ) . ' key dies' ); } if ( $class->_HAS_VALUE() ) { is ( $class->value(), q{}, ( ref $class ) . ' value returns empty string' ); } else { dies_ok( sub{ $class->value() }, ( ref $class ) . ' value dies' ); } } done_testing(); Mail-AuthenticationResults-2.20210915/t/03-parser.t0000644000175000017500000000673214120352241020134 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; my $Parsed = Mail::AuthenticationResults::Parser->new()->parse( ' test.example.com ; foo=bar;dkim=fail ;one=; two ;three;dmarc=pass' ); my $Result = $Parsed->as_string(); is( $Result, "test.example.com;\n foo=bar;\n dkim=fail;\n one=\"\";\n two=\"\";\n three=\"\";\n dmarc=pass", 'Result ok' ); my $Parsed2 = Mail::AuthenticationResults::Parser->new()->parse( 'Authentication-Results: test.example.com;one=two three=four (comment) five=six' ); is ( ref $Parsed2, 'Mail::AuthenticationResults::Header', 'Isa Header' ); is ( scalar @{ $Parsed2->children() }, 1, 'Header with 1 child' ); my $Parsed2Child = $Parsed2->children()->[0]; is ( ref $Parsed2Child, 'Mail::AuthenticationResults::Header::Entry', 'Isa Entry' ); is ( scalar @{ $Parsed2Child->children() }, 2, 'Entry with 2 grandchildren' ); my $Parsed2Grand1 = $Parsed2Child->children()->[0]; is ( ref $Parsed2Grand1, 'Mail::AuthenticationResults::Header::SubEntry', 'First Isa SubEntry' ); is ( scalar @{ $Parsed2Grand1->children() }, 1, 'SubEntry with 2 grandchildren' ); my $Parsed2Grand1Child = $Parsed2Grand1->children()->[0]; is ( ref $Parsed2Grand1Child, 'Mail::AuthenticationResults::Header::Comment', 'Isa Comment' ); dies_ok( sub{ $Parsed2Grand1Child->children() }, 'Comment children throws' ); my $Parsed2Grand2 = $Parsed2Child->children()->[1]; is ( ref $Parsed2Grand2, 'Mail::AuthenticationResults::Header::SubEntry', 'First Isa SubEntry' ); is ( scalar @{ $Parsed2Grand2->children() }, 0, 'SubEntry with 0 grandchildren' ); my $ParsedAuthServID = Mail::AuthenticationResults::Parser->new()->parse( 'test.example.com 1 (this has a version); none' ); my $AuthServIDValue = $ParsedAuthServID->value(); is ( ref $AuthServIDValue, 'Mail::AuthenticationResults::Header::AuthServID', 'AuthServID Object Returned' ); is ( scalar @{ $AuthServIDValue->children() }, 2, 'AuthServID Object has 2 children' ); is ( ref $AuthServIDValue->children()->[1], 'Mail::AuthenticationResults::Header::Version', 'Version Object Returned' ); is ( $AuthServIDValue->children()->[1]->value(), '1', 'Version has correct value' ); is ( ref $AuthServIDValue->children()->[0], 'Mail::AuthenticationResults::Header::Comment', 'Comment Object Returned' ); is ( $AuthServIDValue->children()->[0]->value(), 'this has a version', 'Comment has correct value' ); is ( $AuthServIDValue->as_string(), 'test.example.com (this has a version) 1', 'AuthServID as string is correct' ); is ( $ParsedAuthServID->as_string(), "test.example.com (this has a version) 1; none", 'Header as string is correct' ); my $ParsedCommentFirst = Mail::AuthenticationResults::Parser->new()->parse( '(comment first) test.example.com;none' ); is ( $ParsedCommentFirst->as_string(), "test.example.com (comment first); none", 'Header as string is correct' ); my $ParsedPostAssign; lives_ok( sub{ $ParsedPostAssign = Mail::AuthenticationResults::Parser->new()->parse( 'example.com; dkim=pass address=thisisa=test@example.com') }, 'Post Assign parse lives' ); is( $ParsedPostAssign->children()->[0]->children->[0]->value(), 'thisisa=test@example.com', 'Post assign value correct' ); is( $ParsedPostAssign->children()->[0]->children->[0]->as_string(), 'address="thisisa=test@example.com"', 'Post assign stringify correct' ); dies_ok( sub{ Mail::AuthenticationResults::Parser->new()->parse( ';none' ) }, 'Missing AuthServ-ID dies' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/05-eol.t0000644000175000017500000000212014120352241017404 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; my $Input = [ 'iprev=fail policy.iprev=123.123.123.123 (NOT FOUND)', 'x-ptr=fail x-ptr-helo=bad.name.google.com x-ptr-lookup=', ]; my $InputARHeader = join( ";\n", 'test.example.com', @$Input ); my $Parser = Mail::AuthenticationResults::Parser->new( $InputARHeader ); my $Parsed = $Parser->parsed(); my $LR = "test.example.com;\n iprev=fail policy.iprev=123.123.123.123 (NOT FOUND);\n x-ptr=fail x-ptr-helo=bad.name.google.com x-ptr-lookup=\"\""; my $CRLF = "test.example.com;\r\n iprev=fail policy.iprev=123.123.123.123 (NOT FOUND);\r\n x-ptr=fail x-ptr-helo=bad.name.google.com x-ptr-lookup=\"\""; $Parsed->set_indent_style( 'entry' ); is( $Parsed->as_string(), $LR, 'Default is LR' ); $Parsed->set_eol( "\r\n" ); is( $Parsed->as_string(), $CRLF, 'Set CRLR' ); $Parsed->set_eol( "\n" ); is( $Parsed->as_string(), $LR, 'Set LR' ); dies_ok( sub{ $Parsed->set_eol( "**" ); }, 'Invalid eol dies' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/author-pod-coverage.t0000644000175000017500000000053614120352241022267 0ustar marcmarc#!perl BEGIN { unless ($ENV{AUTHOR_TESTING}) { print qq{1..0 # SKIP these tests are for testing by the author\n}; exit } } # This file was automatically generated by Dist::Zilla::Plugin::PodCoverageTests. use Test::Pod::Coverage 1.08; use Pod::Coverage::TrustPod; all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' }); Mail-AuthenticationResults-2.20210915/t/02-comment.t0000644000175000017500000000554614120352241020303 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Header::Comment; my $Comment; lives_ok( sub{ $Comment = Mail::AuthenticationResults::Header::Comment->new() }, 'new()' ); is( ref $Comment, 'Mail::AuthenticationResults::Header::Comment', 'Returns Comment Object' ); dies_ok( sub{ $Comment->set_key( 'foo' ) }, 'set_key() dies' ); dies_ok( sub{ $Comment->key() }, 'key() dies' ); dies_ok( sub{ $Comment->add_child( $Comment ) }, 'add_child() dies' ); dies_ok( sub{ $Comment->children() }, 'children() dies' ); dies_ok( sub{ $Comment->set_value( 'a(b' ) }, 'set_value("a(b") dies' ); lives_ok( sub{ $Comment->safe_set_value( 'a(b' ) }, 'safe_set_value("a(b") lives' ); is( $Comment->value(), 'a b', 'value() correct value returned' ); dies_ok( sub{ $Comment->set_value( 'a)b' ) }, 'set_value("a)b") dies' ); lives_ok( sub{ $Comment->safe_set_value( 'a)b' ) }, 'safe_set_value("a)b") lives' ); is( $Comment->value(), 'a b', 'value() correct value returned' ); dies_ok( sub{ $Comment->set_value( 'a((b)' ) }, 'set_value("a((b)") dies' ); lives_ok( sub{ $Comment->safe_set_value( 'a((b)' ) }, 'safe_set_value("a((b)") lives' ); is( $Comment->value(), 'a b', 'value() correct value returned' ); dies_ok( sub{ $Comment->set_value( '(b))a' ) }, 'set_value("(b))a") dies' ); lives_ok( sub{ $Comment->safe_set_value( '(b))a' ) }, 'safe_set_value("(b))a") lives' ); is( $Comment->value(), 'b a', 'value() correct value returned' ); dies_ok( sub{ $Comment->set_value( ')(' ) }, 'set_value(")(") dies' ); lives_ok( sub{ $Comment->safe_set_value( ')(' ) }, 'safe_set_value(")(") lives' ); is( $Comment->value(), '', 'value() correct value returned' ); my $SetValue; lives_ok( sub{ $SetValue = $Comment->set_value( 'foo' ) }, 'set_value("foo") lives' ); is( ref $SetValue, 'Mail::AuthenticationResults::Header::Comment', 'Returns Comment Object' ); is( $SetValue, $Comment, 'Returns This Object' ); is( $Comment->value(), 'foo', 'value() correct value returned' ); is( $Comment->as_string(), '(foo)', 'as_string() correct string returned' ); lives_ok( sub{ $SetValue = $Comment->set_value( 'foo(bar)' ) }, 'set_value("foo(bar)") lives' ); is( $Comment->value(), 'foo(bar)', 'value() correct value returned' ); is( $Comment->as_string(), '(foo(bar))', 'as_string() correct string returned' ); lives_ok( sub{ $SetValue = $Comment->safe_set_value( 'foo' ) }, 'safe_set_value("foo") lives' ); is( $Comment->value(), 'foo', 'value() correct value returned' ); is( $Comment->as_string(), '(foo)', 'as_string() correct string returned' ); lives_ok( sub{ $SetValue = $Comment->safe_set_value( 'foo(bar)' ) }, 'safe_set_value("foo(bar)") lives' ); is( $Comment->value(), 'foo(bar)', 'value() correct value returned' ); is( $Comment->as_string(), '(foo(bar))', 'as_string() correct string returned' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/04-yahoo.t0000644000175000017500000000117714120352241017756 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; my $ARHeader = 'Authentication-Results: mta4011.mail.gq1.yahoo.com from=fastmail.com; domainkeys=neutral (no sig); from=messagingengine.com; dkim=pass (ok)'; my $Parsed; lives_ok( sub{ $Parsed = Mail::AuthenticationResults::Parser->new()->parse( $ARHeader ) }, 'Parse lives' ); is ( $Parsed->value()->value(), 'mta4011.mail.gq1.yahoo.com', 'ServID' ); is ( scalar @{$Parsed->search({ 'key'=>'dkim','value'=>'pass' })->children() }, 1, 'DKIM Pass' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/03-search-authserv-id.t0000644000175000017500000000333414120352241022331 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; use Mail::AuthenticationResults::Header::Group; my $Group = Mail::AuthenticationResults::Header::Group->new(); $Group->add_child( Mail::AuthenticationResults::Parser->new()->parse( 'test.example.com;one=two three=four (comment) five=six' ) ); $Group->add_child( Mail::AuthenticationResults::Parser->new()->parse( 'test2.example.com;one=two three=four (comment) five=six' ) ); $Group->add_child( Mail::AuthenticationResults::Parser->new()->parse( 'test.example.org;one=one three=three (comments) five=five' ) ); $Group->add_child( Mail::AuthenticationResults::Parser->new()->parse( 'test.example.org;newone=one newthree=three (comments) newfive=five' ) ); my $Found = $Group->search({ 'isa' => 'header', 'authserv_id' => 'test.example.com' }); $Found->children()->[0]->set_indent_style( 'none' ); is( $Found->as_string(), 'test.example.com; one=two three=four (comment) five=six', 'Found AuthServ ID' ); my $NotFound = $Group->search({ 'authserv_id' => 'test.example.net' }); is( scalar @{$NotFound->children() }, 0, 'Did not find missing AuthServ Id' ); my $FoundRegex = $Group->search({ 'authserv_id' => qr/\.example\.com$/ }); is( scalar @{$FoundRegex->children() }, 2, 'Found 2 results for Regex match' ); my $Found2 = $Group->search({ 'authserv_id' => 'test.example.org' }); is( scalar @{$Found2->children() }, 2, 'Found 2 results for Multiple match' ); my $Value = $Group->search({ 'value' => 'six' }); my $NotRelevant = $Value->search({ 'authserv_id' => 'test.example.com' }); is( scalar @{$NotRelevant->children() }, 0, 'Search on an entry found nothing' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/author-critic.t0000644000175000017500000000040714120352241021166 0ustar marcmarc#!perl BEGIN { unless ($ENV{AUTHOR_TESTING}) { print qq{1..0 # SKIP these tests are for testing by the author\n}; exit } } use strict; use warnings; use Test::Perl::Critic (-profile => "t/perlcritic.rc") x!! -e "t/perlcritic.rc"; all_critic_ok(); Mail-AuthenticationResults-2.20210915/t/04-aol.t0000644000175000017500000000211114120352241017377 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; my $ARHeader = 'mx.aol.com; spf=pass (aol.com: the domain fastmail.com reports 66.111.4.222 as a permitted sender.) smtp.mailfrom=fastmail.com; dkim=pass (aol.com: email passed verification from the domain fastmail.com.) header.i=@fastmail.com; dmarc=pass (aol.com: the domain fastmail.com reports that Both SPF and DKIM strictly align.) header.from=fastmail.com;'; my $Parsed; lives_ok( sub{ $Parsed = Mail::AuthenticationResults::Parser->new()->parse( $ARHeader ) }, 'Parse lives' ); is ( $Parsed->value()->value(), 'mx.aol.com', 'ServID' ); is ( scalar @{$Parsed->search({ 'key'=>'spf','value'=>'pass' })->children() }, 1, 'SPF Pass' ); is ( scalar @{$Parsed->search({ 'key'=>'dkim','value'=>'pass' })->search({ 'key'=>'header.i','value'=>'@fastmail.com' })->children() }, 1, 'DKIM fastmail.com Pass' ); is ( scalar @{$Parsed->search({ 'key'=>'dmarc','value'=>'pass' })->children() }, 1, 'DMARC Pass' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/04-icloud.t0000644000175000017500000000345614120352241020120 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Header::Group; use Mail::AuthenticationResults::Parser; my $Group = Mail::AuthenticationResults::Header::Group->new(); # iCloud adds multiple headers, let's add them all to a group my @ARHeaders = ( 'Authentication-results: mr21p00im-dmarcmilter001.me.com; dmarc=pass header.from=fastmail.com', 'Authentication-results: mr21p00im-spfmilter010.me.com; spf=pass (mr21p00im-spfmilter010.me.com: domain of deliverability@fastmail.com designates 66.111.4.221 as permitted sender) smtp.mailfrom=deliverability@fastmail.com', 'Authentication-results: mr21p00im-dkimmilter005.me.com; dkim=pass (2048-bit key) header.d=messagingengine.com header.i=@messagingengine.com header.b=V9y21l+w; dkim-adsp=pass', 'Authentication-results: mr21p00im-dkimmilter005.me.com; dkim=pass (2048-bit key) header.d=fastmail.com header.i=@fastmail.com header.b=0GObIji6; dkim-adsp=pass', ); foreach my $Header ( @ARHeaders ) { my $Parsed; lives_ok( sub{ $Parsed = Mail::AuthenticationResults::Parser->new()->parse( $Header ) }, 'Parse lives' ); $Group->add_child( $Parsed ); } #is ( $Parsed->value(), 'mxs.mail.ru', 'ServID' ); is ( scalar @{$Group->search({ 'key'=>'spf','value'=>'pass' })->children() }, 1, 'SPF Pass' ); is ( scalar @{$Group->search({ 'key'=>'dkim','value'=>'pass' })->search({ 'key'=>'header.d','value'=>'fastmail.com' })->children() }, 1, 'DKIM fastmail.com Pass' ); is ( scalar @{$Group->search({ 'key'=>'dkim','value'=>'pass' })->search({ 'key'=>'header.d','value'=>'messagingengine.com' })->children() }, 1, 'DKIM messagingengine.com Pass' ); is ( scalar @{$Group->search({ 'key'=>'dmarc','value'=>'pass' })->children() }, 1, 'DMARC Pass' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/04-fastmail.t0000644000175000017500000000274114120352241020435 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; my $ARHeader = 'Authentication-Results: mx6.messagingengine.com; arc=none (no signatures found); dkim=pass (1024-bit rsa key sha256) header.d=mail.ru header.i=@mail.ru header.b=oF80QtY/ x-bits=1024 x-keytype=rsa x-algorithm=sha256 x-selector=mail2; dmarc=pass (p=reject,d=none) header.from=mail.ru; iprev=pass policy.iprev=94.100.177.106 (smtp46.i.mail.ru); spf=pass smtp.mailfrom=fmdeliverability@mail.ru smtp.helo=smtp46.i.mail.ru; x-aligned-from=pass; x-ptr=pass x-ptr-helo=smtp46.i.mail.ru x-ptr-lookup=smtp46.i.mail.ru; x-return-mx=pass smtp.domain=mail.ru smtp.result=pass smtp_is_org_domain=yes header.domain=mail.ru header.result=pass header_is_org_domain=yes; x-tls=pass version=TLSv1.2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128'; my $Parsed; lives_ok( sub{ $Parsed = Mail::AuthenticationResults::Parser->new()->parse( $ARHeader ) }, 'Parse lives' ); is ( $Parsed->value()->value(), 'mx6.messagingengine.com', 'ServID' ); is ( scalar @{$Parsed->search({ 'key'=>'spf','value'=>'pass' })->children() }, 1, 'SPF Pass' ); is ( scalar @{$Parsed->search({ 'key'=>'dkim','value'=>'pass' })->search({ 'key'=>'header.i','value'=>'@mail.ru' })->children() }, 1, 'DKIM Pass' ); is ( scalar @{$Parsed->search({ 'key'=>'dmarc','value'=>'pass' })->children() }, 1, 'DMARC Pass' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/02-set.t0000644000175000017500000001462614120352241017433 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Header; use Mail::AuthenticationResults::Header::Base; use Mail::AuthenticationResults::Header::Comment; use Mail::AuthenticationResults::Header::Entry; use Mail::AuthenticationResults::Header::Group; use Mail::AuthenticationResults::Header::SubEntry; use Mail::AuthenticationResults::Header::Version; use Mail::AuthenticationResults::Header::AuthServID; my $Base = Mail::AuthenticationResults::Header::Base->new(); my $Comment = Mail::AuthenticationResults::Header::Comment->new(); my $Entry = Mail::AuthenticationResults::Header::Entry->new(); my $Group = Mail::AuthenticationResults::Header::Group->new(); my $Header = Mail::AuthenticationResults::Header->new(); my $SubEntry = Mail::AuthenticationResults::Header::SubEntry->new(); my $Version = Mail::AuthenticationResults::Header::Version->new(); my $AuthServID = Mail::AuthenticationResults::Header::AuthServID->new(); test_key_dies( $Base ); test_key_dies( $Comment ); test_key_dies( $Entry ); test_key_dies( $Group ); #test_key_dies( $Header ); # Header does not have keys test_key_dies( $SubEntry ); #test_key_dies( $Version ); $AuthServID does not have keys #test_key_dies( $AuthServID ); #AuthServID does not have keys test_value_dies( $Base ); #test_value_dies( $Comment ); # Tested elsewhere test_value_dies( $Entry ); test_value_dies( $Group ); test_value_dies_header( $Header ); test_value_dies( $SubEntry ); test_value_dies( $AuthServID ); test_value_dies_version( $Version ); sub test_key_dies { my ( $class ) = @_; if ( ! $class->_HAS_KEY() ) { dies_ok( sub{ $class->set_key() }, ( ref $class ) . ' set key' ); return; } $class->set_value( 'test' ); dies_ok( sub{ $class->set_key() }, ( ref $class ) . ' set null key' ); dies_ok( sub{ $class->set_key( '' ) }, ( ref $class ) . ' set empty key' ); dies_ok( sub{ $class->set_key( '"' ) }, ( ref $class ) . ' set invalid " key' ); dies_ok( sub{ $class->set_key( "with\nnewline" ) }, ( ref $class ) . ' set invalid newline key' ); dies_ok( sub{ $class->set_key( "with\rreturn" ) }, ( ref $class ) . ' set invalid return key' ); delete $class->{ 'value' }; lives_ok( sub{ $class->set_key( 'none' ) }, ( ref $class ) . ' set key none' ); is( $class->as_string(), 'none', ( ref $class ) . ' stringifies none correctly' ); $class->set_value( 'test' ); lives_ok( sub{ $class->set_key( 'test key!' ) }, ( ref $class ) . ' set key spaces' ); is( $class->as_string(), '"test key!"=test', ( ref $class ) . ' stringifies spaces correctly' ); lives_ok( sub{ $class->set_key( 'test;' ) }, ( ref $class ) . ' set key semicolon' ); is( $class->as_string(), '"test;"=test', ( ref $class ) . ' stringifies semicolon correctly' ); lives_ok( sub{ $class->set_key( 'test(test)' ) }, ( ref $class ) . ' set key parens' ); is( $class->as_string(), '"test(test)"=test', ( ref $class ) . ' stringifies parens correctly' ); } sub test_value_dies { my ( $class ) = @_; if ( ! $class->_HAS_VALUE() ) { dies_ok( sub{ $class->set_value() }, ( ref $class ) . ' set value' ); return; } my $expectkey = q{}; if ( $class->_HAS_KEY() ) { $class->set_key( 'test' ); $expectkey = 'test='; } dies_ok( sub{ $class->set_value() }, ( ref $class ) . ' set null value' ); dies_ok( sub{ $class->set_value( 'has"quote') }, ( ref $class ) . ' set quote value value' ); dies_ok( sub{ $class->set_value( "with\nnewline" ) }, ( ref $class ) . ' set newline value' ); dies_ok( sub{ $class->set_value( "with\return" ) }, ( ref $class ) . ' set return value' ); lives_ok( sub{ $class->set_value( 'With space' ) }, ( ref $class ) . ' set invalid value spaces' ); is( $class->as_string(), $expectkey . '"With space"', ( ref $class ) . ' stringifies spaces correctly' ); lives_ok( sub{ $class->set_value( 'pass;' ) }, ( ref $class ) . ' set invalid value semicolon' ); is( $class->as_string(), $expectkey . '"pass;"', ( ref $class ) . ' stringifies semicolon correctly' ); lives_ok( sub{ $class->set_value( 'with(parens)' ) }, ( ref $class ) . ' set invalid value comment' ); is( $class->as_string(), $expectkey . '"with(parens)"', ( ref $class ) . ' stringifies parens correctly' ); if ( ref $class ne 'Mail::AuthenticationResults::Header::AuthServID' ) { lives_ok( sub{ $class->set_value( '' ) }, ( ref $class ) . ' set empty string' ); is( $class->as_string(), $expectkey . '""', ( ref $class ) . ' stringifies empty correctly' ); } lives_ok( sub{ $class->set_value( 0 ) }, ( ref $class ) . ' set zero' ); is( $class->as_string(), $expectkey . '0', ( ref $class ) . ' stringifies zero correctly' ); } sub test_value_dies_version { my ( $class ) = @_; return unless $class->_HAS_VALUE(); dies_ok( sub{ $class->set_value() }, ( ref $class ) . ' set null value' ); dies_ok( sub{ $class->set_value( 'AString' ) }, ( ref $class ) . ' set invalid value non numeric' ); dies_ok( sub{ $class->set_value( 'With space' ) }, ( ref $class ) . ' set invalid value spaces' ); lives_ok( sub{ $class->set_value( '12345' ) }, ( ref $class ) . ' set valid value' ); is( $class->as_string(), '/ 12345', ( ref $class ) . ' stringifies version correctly' ); } sub test_value_dies_header { my ( $class ) = @_; return unless $class->_HAS_VALUE(); dies_ok( sub{ $class->set_value() }, ( ref $class ) . ' set null value' ); dies_ok( sub{ $class->set_value( 'string' ) }, ( ref $class ) . ' set incorrect type value' ); lives_ok( sub{ $class->set_value( Mail::AuthenticationResults::Header::AuthServID->new()->set_value( 'With space' ) ) }, ( ref $class ) . ' set invalid value spaces' ); is( $class->as_string(), '"With space"; none', ( ref $class ) . ' stringifies spaces correctly' ); lives_ok( sub{ $class->set_value( Mail::AuthenticationResults::Header::AuthServID->new()->set_value( 'pass;' ) ) }, ( ref $class ) . ' set invalid value semicolon' ); is( $class->as_string(), '"pass;"; none', ( ref $class ) . ' stringifies semicolon correctly' ); lives_ok( sub{ $class->set_value( Mail::AuthenticationResults::Header::AuthServID->new()->set_value( 'with(parens)' ) ) }, ( ref $class ) . ' set invalid value comment' ); is( $class->as_string(), '"with(parens)"; none', ( ref $class ) . ' stringifies parens correctly' ); } done_testing(); Mail-AuthenticationResults-2.20210915/t/04-yandex.t0000644000175000017500000000162314120352241020123 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; my $ARHeader = 'Authentication-Results: mxfront8g.mail.yandex.net; spf=pass (mxfront8g.mail.yandex.net: domain of fastmail.com designates 66.111.4.222 as permitted sender, rule=[ip4:66.111.4.0/24]) smtp.mail=deliverability@fastmail.com; dkim=pass header.i=@fastmail.com'; my $Parsed; lives_ok( sub{ $Parsed = Mail::AuthenticationResults::Parser->new()->parse( $ARHeader ) }, 'Parse lives' ); is ( $Parsed->value()->value(), 'mxfront8g.mail.yandex.net', 'ServID' ); is ( scalar @{$Parsed->search({ 'key'=>'spf','value'=>'pass' })->children() }, 1, 'SPF Pass' ); is ( scalar @{$Parsed->search({ 'key'=>'dkim','value'=>'pass' })->search({ 'key'=>'header.i','value'=>'@fastmail.com' })->children() }, 1, 'DKIM fastmail.com Pass' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/04-gmail.t0000644000175000017500000000247714120352241017734 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; my $ARHeader = 'Authentication-Results: mx.google.com; dkim=pass header.i=@fastmail.com header.s=fm1 header.b=2j32dcmg; dkim=pass header.i=@messagingengine.com header.s=fm1 header.b=dgrCnA5f; spf=pass (google.com: domain of deliverability@fastmail.com designates 66.111.4.26 as permitted sender) smtp.mailfrom=deliverability@fastmail.com; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=fastmail.com'; my $Parsed; lives_ok( sub{ $Parsed = Mail::AuthenticationResults::Parser->new()->parse( $ARHeader ) }, 'Parse lives' ); is ( $Parsed->value()->value(), 'mx.google.com', 'ServID' ); is ( scalar @{$Parsed->search({ 'key'=>'spf','value'=>'pass' })->children() }, 1, 'SPF Pass' ); is ( scalar @{$Parsed->search({ 'key'=>'dkim','value'=>'pass' })->search({ 'key'=>'header.i','value'=>'@fastmail.com' })->children() }, 1, 'DKIM fastmail.com Pass' ); is ( scalar @{$Parsed->search({ 'key'=>'dkim','value'=>'pass' })->search({ 'key'=>'header.i','value'=>'@messagingengine.com' })->children() }, 1, 'DKIM messagingengine.com Pass' ); is ( scalar @{$Parsed->search({ 'key'=>'dmarc','value'=>'pass' })->children() }, 1, 'DMARC Pass' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/05-parser-comment-heavy.t0000644000175000017500000000157414120352241022707 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; my $ARHeader = "Authentication-Results: foo.example.net (foobar) 1 (baz); dkim (Because I like it) / 1 (One yay) = (wait for it) fail policy (A dot can go here) . (like that) expired (this surprised me) = (as I wasn't expecting it) 1362471462"; my $AsString = "foo.example.net (foobar) (baz) 1; dkim=fail (Because I like it) / 1 (One yay) (wait for it) policy.expired=1362471462 (A dot can go here) (like that) (this surprised me) (as I wasn't expecting it)"; my $Parsed; lives_ok( sub{ $Parsed = Mail::AuthenticationResults::Parser->new()->parse( $ARHeader ) }, 'Comment heavy example parses' ); is( $Parsed->as_string, $AsString, 'as string is as expected' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/04-mail.ru.t0000644000175000017500000000233314120352241020201 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; my $ARHeader = 'mxs.mail.ru; spf=pass (mx159.mail.ru: domain of fastmail.com designates 66.111.4.221 as permitted sender) smtp.mailfrom=deliverability@fastmail.com smtp.helo=new1-smtp.messagingengine.com; dkim=pass header.d=fastmail.com; dkim=pass header.d=messagingengine.com; dmarc=pass header.from=deliverability@fastmail.com'; my $Parsed; lives_ok( sub{ $Parsed = Mail::AuthenticationResults::Parser->new()->parse( $ARHeader ) }, 'Parse lives' ); is ( $Parsed->value()->value(), 'mxs.mail.ru', 'ServID' ); is ( scalar @{$Parsed->search({ 'key'=>'spf','value'=>'pass' })->children() }, 1, 'SPF Pass' ); is ( scalar @{$Parsed->search({ 'key'=>'dkim','value'=>'pass' })->search({ 'key'=>'header.d','value'=>'fastmail.com' })->children() }, 1, 'DKIM fastmail.com Pass' ); is ( scalar @{$Parsed->search({ 'key'=>'dkim','value'=>'pass' })->search({ 'key'=>'header.d','value'=>'messagingengine.com' })->children() }, 1, 'DKIM messagingengine.com Pass' ); is ( scalar @{$Parsed->search({ 'key'=>'dmarc','value'=>'pass' })->children() }, 1, 'DMARC Pass' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/03-search.t0000644000175000017500000000430414120352241020076 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; my $Parsed = Mail::AuthenticationResults::Parser->new()->parse( 'test.example.com;one=two three=four (comment) five=six' ); my $Key = $Parsed->search({ 'key' => 'three' }); is( $Key->as_string(), 'three=four (comment)', 'Found key' ); my $RxKey = $Parsed->search({ 'key' => qr/^three$/ }); is( $RxKey->as_string(), 'three=four (comment)', 'Found Regex key' ); my $Value = $Parsed->search({ 'value' => 'six' }); is ( $Value->as_string, 'five=six', 'Found value' ); my $RxValue = $Parsed->search({ 'value' => qr/^six$/ }); is ( $RxValue->as_string, 'five=six', 'Found Regex value' ); my $NoKey = $Parsed->search({ 'key' => 'four' }); is( $NoKey->as_string(), '', 'Not found key' ); my $NoValue = $Parsed->search({ 'value' => 'five' }); is ( $NoValue->as_string, '', 'Not found value' ); my $Entry = $Parsed->search({ 'isa' => 'entry' }); is ( $Entry->as_string(), 'one=two three=four (comment) five=six', 'Entry search' ); is ( scalar @{$Entry->children()}, 1, 'One found' ); my $Header = $Parsed->search({ 'isa' => 'header' }); is ( $Header->as_string(), "test.example.com;\n one=two three=four (comment) five=six", 'Entry search' ); my $SubEntry = $Parsed->search({ 'isa' => 'subentry' }); is ( $SubEntry->as_string(), "three=four (comment);\nfive=six", 'SubEntry search' ); is ( scalar @{$SubEntry->children()}, 2, 'Two found' ); is( scalar @{ $SubEntry->search({ 'isa' => 'entry' })->children() }, 0, 'Entry not found under SubEntry' ); my $Comment = $Parsed->search({ 'isa' => 'comment' }); is ( $Comment->as_string(), '(comment)', 'Comment search' ); is ( scalar @{$Comment->children()}, 1, 'One found' ); is( scalar @{ $Comment->search({ 'isa' => 'entry' })->children() }, 0, 'Entry not found under Comment' ); is( scalar @{ $Comment->search({ 'isa' => 'subentry' })->children() }, 0, 'SubEntry not found under Comment' ); is( scalar @{ $Entry->search({ 'key' => 'notfound' })->children() }, 0, 'Search key fail under Entry' ); is( scalar @{ $Entry->search({ 'value' => 'notfound' })->children() }, 0, 'Search value fail under Entry' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/02-parser-begin-dot.t0000644000175000017500000000261314120352241021773 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; #plan tests => noplan1; chdir 't'; my $Input = [ 'dmarc=fail (p=none,d=none) header.from=.net', 'dmarc=fail (p=none,d=none) header.from=..net', ]; my $Output = [ 'dmarc=fail (p=none,d=none) header.from=.net', 'dmarc=fail (p=none,d=none) header.from=..net', ]; my $InputARHeader = join( ";\n", 'test.example.com', @$Input ); my $Parser; dies_ok( sub{ $Parser = Mail::AuthenticationResults::Parser->new()->parse( '' ) }, 'Parser dies on empty' ); lives_ok( sub{ $Parser = Mail::AuthenticationResults::Parser->new( $InputARHeader ) }, 'Parser parses' ); is( ref $Parser, 'Mail::AuthenticationResults::Parser', 'Returns Parser Object' ); my $Header; lives_ok( sub{ $Header = $Parser->parsed() }, 'Parser returns data' ); is( ref $Header, 'Mail::AuthenticationResults::Header', 'Returns Header Object' ); is( $Header->value()->value(), 'test.example.com', 'Authserve Id correct' ); is( $Header->as_string(), join( ";\n ", 'test.example.com', @$Output ), 'As String data matches input data' ); is( $Header->search({'isa'=>'subentry','key'=>'header.from'})->children->[0]->value, '.net', 'Value 0 correct' ); is( $Header->search({'isa'=>'subentry','key'=>'header.from'})->children->[1]->value, '..net', 'Value 1 correct' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/05-as-json.t0000644000175000017500000000465714120352241020220 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; my $Header = 'test.example.com; iprev=fail policy.iprev=123.123.123.123 (NOT FOUND); x-ptr=fail x-ptr-helo=bad.name.google.com x-ptr-lookup=""; spf=fail smtp.mailfrom=test@goestheweasel.com smtp.helo=bad.name.google.com; dkim=none (no signatures found); x-google-dkim=none (no signatures found); dmarc=fail (p=none,d=none) header.from=marcbradshaw.net; dmarc=fail (p=reject,d=reject) header.from=goestheweasel.com; dmarc=none (p=none,d=none) header.from=example.com'; my $Parser = Mail::AuthenticationResults::Parser->new( $Header ); my $Parsed = $Parser->parsed(); my $AsJson = '{"authserv_id":{"children":[],"type":"authservid","value":"test.example.com"},"children":[{"children":[{"children":[{"type":"comment","value":"NOT FOUND"}],"key":"policy.iprev","type":"subentry","value":"123.123.123.123"}],"key":"iprev","type":"entry","value":"fail"},{"children":[{"children":[],"key":"x-ptr-helo","type":"subentry","value":"bad.name.google.com"},{"children":[],"key":"x-ptr-lookup","type":"subentry","value":""}],"key":"x-ptr","type":"entry","value":"fail"},{"children":[{"children":[],"key":"smtp.mailfrom","type":"subentry","value":"test@goestheweasel.com"},{"children":[],"key":"smtp.helo","type":"subentry","value":"bad.name.google.com"}],"key":"spf","type":"entry","value":"fail"},{"children":[{"type":"comment","value":"no signatures found"}],"key":"dkim","type":"entry","value":"none"},{"children":[{"type":"comment","value":"no signatures found"}],"key":"x-google-dkim","type":"entry","value":"none"},{"children":[{"type":"comment","value":"p=none,d=none"},{"children":[],"key":"header.from","type":"subentry","value":"marcbradshaw.net"}],"key":"dmarc","type":"entry","value":"fail"},{"children":[{"type":"comment","value":"p=reject,d=reject"},{"children":[],"key":"header.from","type":"subentry","value":"goestheweasel.com"}],"key":"dmarc","type":"entry","value":"fail"},{"children":[{"type":"comment","value":"p=none,d=none"},{"children":[],"key":"header.from","type":"subentry","value":"example.com"}],"key":"dmarc","type":"entry","value":"none"}],"type":"header"}'; is ( $Parsed->as_json(), $AsJson, 'JSON Serialised as expected' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/03-parser-bogus.t0000644000175000017500000000206014120352241021237 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; my $Parsed; my @GoodStrings = ( 'test.example.com foo;', 'test.example.com foo ', 'test.example.com; foo = ', ); my @BadStrings = ( 'test.example.com = = test;', 'test.example.com foo = = bar;', 'test.example.com . bar = test;', 'test.example.com foo . bar = test;', 'test.example.com foo / bar = test;', 'test.example.com foo bar = test;', 'test.example.com; foo = = bar;', 'test.example.com; foo / bar = test;', 'test.example.com; foo . . bar = test;', 'test.example.com; foo / . bar = test;', 'test.example.com; foo . / bar = test;', ); foreach my $String ( @GoodStrings ) { lives_ok( sub{ $Parsed = Mail::AuthenticationResults::Parser->new()->parse( $String ) }, $String ); } foreach my $String ( @BadStrings ) { dies_ok( sub{ $Parsed = Mail::AuthenticationResults::Parser->new()->parse( $String ) }, $String ); } done_testing(); Mail-AuthenticationResults-2.20210915/t/02-safe_set.t0000644000175000017500000001201314120352241020415 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Header; use Mail::AuthenticationResults::Header::Base; use Mail::AuthenticationResults::Header::Comment; use Mail::AuthenticationResults::Header::Entry; use Mail::AuthenticationResults::Header::Group; use Mail::AuthenticationResults::Header::SubEntry; use Mail::AuthenticationResults::Header::Version; use Mail::AuthenticationResults::Header::AuthServID; my $Base = Mail::AuthenticationResults::Header::Base->new(); my $Comment = Mail::AuthenticationResults::Header::Comment->new(); my $Entry = Mail::AuthenticationResults::Header::Entry->new(); my $Group = Mail::AuthenticationResults::Header::Group->new(); my $Header = Mail::AuthenticationResults::Header->new(); my $SubEntry = Mail::AuthenticationResults::Header::SubEntry->new(); my $Version = Mail::AuthenticationResults::Header::Version->new(); my $AuthServID = Mail::AuthenticationResults::Header::AuthServID->new(); test_value_dies( $Base ); #test_value_dies( $Comment ); # Tests not yet written test_value_dies( $Entry ); test_value_dies( $Group ); test_value_dies_header( $Header ); test_value_dies( $SubEntry ); test_value_dies( $AuthServID ); test_value_dies_version( $Version ); sub test_value_dies { my ( $class ) = @_; if ( ! $class->_HAS_VALUE() ) { dies_ok( sub{ $class->set_value() }, ( ref $class ) . ' set value' ); return; } my $expectkey = q{}; if ( $class->_HAS_KEY() ) { $class->set_key( 'test' ); $expectkey = 'test='; } lives_ok( sub{ $class->safe_set_value() }, ( ref $class ) . ' set null value' ); if ( ref $class eq 'Mail::AuthenticationResults::Header::AuthServID' ) { is( $class->as_string(), $expectkey . '', ( ref $class ) . ' stringify null correctly' ); } else { is( $class->as_string(), $expectkey . '""', ( ref $class ) . ' stringify null correctly' ); } lives_ok( sub{ $class->safe_set_value( 'With space' ) }, ( ref $class ) . ' set invalid value spaces' ); is( $class->as_string(), $expectkey . '"With space"', ( ref $class ) . ' stringifies spaces correctly' ); lives_ok( sub{ $class->safe_set_value( 'pass;' ) }, ( ref $class ) . ' set invalid value semicolon' ); is( $class->as_string(), $expectkey . 'pass', ( ref $class ) . ' stringifies semicolon correctly' ); lives_ok( sub{ $class->safe_set_value( 'with(parens)' ) }, ( ref $class ) . ' set invalid value comment' ); is( $class->as_string(), $expectkey . '"with parens"', ( ref $class ) . ' stringifies parens correctly' ); lives_ok( sub{ $class->safe_set_value( "With\nnewline" ) }, ( ref $class ) . ' set invalid value newline' ); is( $class->as_string(), $expectkey . '"With newline"', ( ref $class ) . ' stringifies newline correctly' ); lives_ok( sub{ $class->safe_set_value( "With\rreturn" ) }, ( ref $class ) . ' set invalid value return' ); is( $class->as_string(), $expectkey . '"With return"', ( ref $class ) . ' stringifies return correctly' ); } sub test_value_dies_version { my ( $class ) = @_; return unless $class->_HAS_VALUE(); lives_ok( sub{ $class->safe_set_value() }, ( ref $class ) . ' set null value' ); is( $class->as_string(), '/ 1', ( ref $class ) . ' stringifies null version correctly' ); lives_ok( sub{ $class->safe_set_value( 'AString' ) }, ( ref $class ) . ' set invalid value non numeric' ); is( $class->as_string(), '/ 1', ( ref $class ) . ' stringifies non numeric version correctly' ); lives_ok( sub{ $class->safe_set_value( 'With space' ) }, ( ref $class ) . ' set invalid value spaces' ); is( $class->as_string(), '/ 1', ( ref $class ) . ' stringifies spaced version correctly' ); lives_ok( sub{ $class->set_value( '12345' ) }, ( ref $class ) . ' set valid value' ); is( $class->as_string(), '/ 12345', ( ref $class ) . ' stringifies version correctly' ); } sub test_value_dies_header { my ( $class ) = @_; return unless $class->_HAS_VALUE(); dies_ok( sub{ $class->safe_set_value() }, ( ref $class ) . ' set null value' ); dies_ok( sub{ $class->safe_set_value( 'string' ) }, ( ref $class ) . ' set incorrect type value' ); lives_ok( sub{ $class->safe_set_value( Mail::AuthenticationResults::Header::AuthServID->new()->set_value( 'With space' ) ) }, ( ref $class ) . ' set invalid value spaces' ); is( $class->as_string(), '"With space"; none', ( ref $class ) . ' stringifies spaces correctly' ); lives_ok( sub{ $class->safe_set_value( Mail::AuthenticationResults::Header::AuthServID->new()->set_value( 'pass;' ) ) }, ( ref $class ) . ' set invalid value semicolon' ); is( $class->as_string(), '"pass;"; none', ( ref $class ) . ' stringifies semicolon correctly' ); lives_ok( sub{ $class->safe_set_value( Mail::AuthenticationResults::Header::AuthServID->new()->set_value( 'with(parens)' ) ) }, ( ref $class ) . ' set invalid value comment' ); is( $class->as_string(), '"with(parens)"; none', ( ref $class ) . ' stringifies parens correctly' ); } done_testing(); Mail-AuthenticationResults-2.20210915/t/05-as_string-styles.t0000644000175000017500000000661314120352241022152 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; my $Input = [ 'iprev=fail policy.iprev=123.123.123.123 (NOT FOUND)', 'x-ptr=fail x-ptr-helo=bad.name.google.com x-ptr-lookup=', 'spf=fail smtp.mailfrom=test@goestheweasel.com smtp.helo=bad.name.google.com', 'dkim=none (no signatures found)', 'x-google-dkim=none (no signatures found)', 'dmarc=fail (p=none,d=none) header.from=marcbradshaw.net', 'dmarc=fail (p=reject,d=reject) header.from=goestheweasel.com', 'dmarc=none (p=none,d=none) header.from=example.com' ]; my $InputARHeader = join( ";\n", 'test.example.com', @$Input ); my $Parser = Mail::AuthenticationResults::Parser->new( $InputARHeader ); my $Parsed = $Parser->parsed(); my $None = 'test.example.com; iprev=fail policy.iprev=123.123.123.123 (NOT FOUND); x-ptr=fail x-ptr-helo=bad.name.google.com x-ptr-lookup=""; spf=fail smtp.mailfrom=test@goestheweasel.com smtp.helo=bad.name.google.com; dkim=none (no signatures found); x-google-dkim=none (no signatures found); dmarc=fail (p=none,d=none) header.from=marcbradshaw.net; dmarc=fail (p=reject,d=reject) header.from=goestheweasel.com; dmarc=none (p=none,d=none) header.from=example.com'; my $Entry = 'test.example.com; iprev=fail policy.iprev=123.123.123.123 (NOT FOUND); x-ptr=fail x-ptr-helo=bad.name.google.com x-ptr-lookup=""; spf=fail smtp.mailfrom=test@goestheweasel.com smtp.helo=bad.name.google.com; dkim=none (no signatures found); x-google-dkim=none (no signatures found); dmarc=fail (p=none,d=none) header.from=marcbradshaw.net; dmarc=fail (p=reject,d=reject) header.from=goestheweasel.com; dmarc=none (p=none,d=none) header.from=example.com'; my $SubEntry = 'test.example.com; iprev=fail policy.iprev=123.123.123.123 (NOT FOUND); x-ptr=fail x-ptr-helo=bad.name.google.com x-ptr-lookup=""; spf=fail smtp.mailfrom=test@goestheweasel.com smtp.helo=bad.name.google.com; dkim=none (no signatures found); x-google-dkim=none (no signatures found); dmarc=fail (p=none,d=none) header.from=marcbradshaw.net; dmarc=fail (p=reject,d=reject) header.from=goestheweasel.com; dmarc=none (p=none,d=none) header.from=example.com'; my $Full = 'test.example.com; iprev=fail policy.iprev=123.123.123.123 (NOT FOUND); x-ptr=fail x-ptr-helo=bad.name.google.com x-ptr-lookup=""; spf=fail smtp.mailfrom=test@goestheweasel.com smtp.helo=bad.name.google.com; dkim=none (no signatures found); x-google-dkim=none (no signatures found); dmarc=fail (p=none,d=none) header.from=marcbradshaw.net; dmarc=fail (p=reject,d=reject) header.from=goestheweasel.com; dmarc=none (p=none,d=none) header.from=example.com'; is( $Parsed->set_indent_style( 'none' )->as_string(), $None, 'None stringifies correctly' ); is( $Parsed->set_indent_style( 'entry' )->as_string(), $Entry, 'Entry stringifies correctly' ); is( $Parsed->set_indent_style( 'subentry' )->as_string(), $SubEntry, 'SubEntry stringifies correctly' ); is( $Parsed->set_indent_style( 'full' )->as_string(), $Full, 'Full stringifies correctly' ); dies_ok( sub{ $Parsed->set_indent_style( 'bogus_indent_style' ); }, 'invalid style dies' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/02-tokens.t0000644000175000017500000001160114120352241020131 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Token; use Mail::AuthenticationResults::Token::Assignment; use Mail::AuthenticationResults::Token::Comment; use Mail::AuthenticationResults::Token::QuotedString; use Mail::AuthenticationResults::Token::Separator; use Mail::AuthenticationResults::Token::String; use Mail::AuthenticationResults::Token::Space; my $token; # Base token subtest 'base' => sub{ dies_ok( sub{ $token = Mail::AuthenticationResults::Token->new( 'test' ); }, 'Base token dies' ); }; # Assignment token subtest 'assignment' => sub{ lives_ok( sub{ $token = Mail::AuthenticationResults::Token::Assignment->new( '=test' ); }, 'Assignment token = lives' ); is( $token->value(), '=', 'value correct' ); is( $token->remainder(), 'test', 'remainder correct' ); lives_ok( sub{ $token = Mail::AuthenticationResults::Token::Assignment->new( '/test' ); }, 'Assignment token / lives' ); is( $token->value(), '/', 'value correct' ); is( $token->remainder(), 'test', 'remainder correct' ); lives_ok( sub{ $token = Mail::AuthenticationResults::Token::Assignment->new( '.test' ); }, 'Assignment token . lives' ); is( $token->value(), '.', 'value correct' ); is( $token->remainder(), 'test', 'remainder correct' ); dies_ok( sub{ $token = Mail::AuthenticationResults::Token::Assignment->new( 'test' ); }, 'Assignment token test dies' ); }; # Comment token subtest 'comment' => sub{ lives_ok( sub{ $token = Mail::AuthenticationResults::Token::Comment->new( '(Comment) test' ); }, 'Comment token lives' ); is( $token->value(), 'Comment', 'value correct' ); is( $token->remainder(), ' test', 'remainder correct' ); dies_ok( sub{ $token = Mail::AuthenticationResults::Token::Comment->new( 'Comment test' ); }, 'Comment token not comment dies' ); dies_ok( sub{ $token = Mail::AuthenticationResults::Token::Comment->new( '((Comment) test' ); }, 'Comment token not closed dies' ); lives_ok( sub{ $token = Mail::AuthenticationResults::Token::Comment->new( '(Comment)) test' ); }, 'Comment token not opened lives' ); # parses the comment it can is( $token->value(), 'Comment', 'value correct' ); is( $token->remainder(), ') test', 'remainder correct' ); }; # Quoted String Token subtest 'quoted_string' => sub{ lives_ok( sub{ $token = Mail::AuthenticationResults::Token::QuotedString->new( '"Quoted String" test' ); }, 'Quoted String token lives' ); is( $token->value(), 'Quoted String', 'value correct' ); is( $token->remainder(), ' test', 'remainder correct' ); lives_ok( sub{ $token = Mail::AuthenticationResults::Token::QuotedString->new( '"" test' ); }, 'Quoted String token empty lives' ); is( $token->value(), '', 'value correct' ); is( $token->remainder(), ' test', 'remainder correct' ); dies_ok( sub{ $token = Mail::AuthenticationResults::Token::QuotedString->new( '"Quoted String test' ); }, 'Quoted String token not closed dies' ); dies_ok( sub{ $token = Mail::AuthenticationResults::Token::QuotedString->new( 'Not a Quoted String' ); }, 'Quoted String token not quoted dies' ); }; # Separator Token subtest 'separator' => sub{ lives_ok( sub{ $token = Mail::AuthenticationResults::Token::Separator->new( ';test' ); }, 'Separator token ; lives' ); is( $token->value(), ';', 'value correct' ); is( $token->remainder(), 'test', 'remainder correct' ); dies_ok( sub{ $token = Mail::AuthenticationResults::Token::Separator->new( 'test' ); }, 'Separator token test dies' ); }; # String Token subtest 'string' => sub{ lives_ok( sub{ $token = Mail::AuthenticationResults::Token::String->new( 'String test' ); }, 'String token lives' ); is( $token->value(), 'String', 'value correct' ); is( $token->remainder(), ' test', 'remainder correct' ); dies_ok( sub{ $token = Mail::AuthenticationResults::Token::String->new( ' Space test' ); }, 'String token space dies' ); dies_ok( sub{ $token = Mail::AuthenticationResults::Token::String->new( "\t Tab test" ); }, 'String token tab dies' ); dies_ok( sub{ $token = Mail::AuthenticationResults::Token::String->new( '"Quoted test' ); }, 'String token quoted dies' ); dies_ok( sub{ $token = Mail::AuthenticationResults::Token::String->new( '(Comment test' ); }, 'String token comment dies' ); dies_ok( sub{ $token = Mail::AuthenticationResults::Token::String->new( ';Separator test' ); }, 'String token separator dies' ); }; # Space Token subtest 'space' => sub{ dies_ok( sub{ $token = Mail::AuthenticationResults::Token::Space->new( 'Space test' ); }, 'Space token dies' ); lives_ok( sub{ $token = Mail::AuthenticationResults::Token::Space->new_from_value( ' ' ); }, 'Space token lives' ); is( $token->value(), ' ', 'value correct' ); dies_ok( sub{ $token->parse(); }, 'Parse dies' ); dies_ok( sub{ $token->remainder(); }, 'Remainder dies' ); }; done_testing(); Mail-AuthenticationResults-2.20210915/t/03-search-has.t0000644000175000017500000000233214120352241020646 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; my $Parsed = Mail::AuthenticationResults::Parser->new()->parse( 'test.example.com;one=two three=four (comment) five=six' ); my $Found; $Found = $Parsed->search({ 'isa' => 'entry', 'key' => 'one', 'has' => [ { 'isa' => 'subentry', 'key' => 'three' } ] }); is( $Found->as_string(), 'one=two three=four (comment) five=six', 'Found subentry' ); $Found = $Parsed->search({ 'isa' => 'entry', 'key' => 'one', 'has' => [ { 'isa' => 'subentry', 'key' => 'twenty' } ] }); is( scalar @{$Found->children() }, 0, 'Did not find missing subentry' ); $Found = $Parsed->search({ 'isa' => 'entry', 'key' => 'one', 'has' => [ { 'isa' => 'subentry', 'key' => 'twenty' }, { 'isa' => 'subentry', 'key' => 'three' } ] }); is( scalar @{$Found->children() }, 0, 'Did not find missing subentry in multi search' ); $Found = $Parsed->search({ 'isa' => 'entry', 'key' => 'one', 'has' => [ { 'isa' => 'subentry', 'key' => 'three', 'has' => [ { 'value' => 'four' } ] } ] }); is( $Found->as_string(), 'one=two three=four (comment) five=six', 'Found subentry with recursive search' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/02-none.t0000644000175000017500000000312614120352241017570 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; my $Parsed; lives_ok( sub{ $Parsed = Mail::AuthenticationResults::Parser->new()->parse( 'example.com;none' ) }, 'Simple none parses' ); is( $Parsed->as_string, "example.com; none", 'as string is as expected' ); is( scalar @{ $Parsed->children() }, 0, 'no children' ); lives_ok( sub{ $Parsed = Mail::AuthenticationResults::Parser->new()->parse( 'example.com;' ) }, 'Missing none parses' ); is( $Parsed->as_string, "example.com; none", 'as string is as expected' ); is( scalar @{ $Parsed->children() }, 0, 'no children' ); lives_ok( sub{ $Parsed = Mail::AuthenticationResults::Parser->new()->parse( 'example.com; (Nothing here) none' ) }, 'Commented none parses' ); is( $Parsed->as_string, "example.com; (Nothing here) none", 'as string is as expected' ); is( scalar @{ $Parsed->children() }, 1, '1 child' ); # The following is against RFC, but we parse it anyway. lives_ok( sub{ $Parsed = Mail::AuthenticationResults::Parser->new()->parse( 'example.com; none (Nothing here)' ) }, 'Commented none wrong way around parses' ); is( $Parsed->as_string, "example.com; (Nothing here) none", 'as string is as expected' ); is( scalar @{ $Parsed->children() }, 1, '1 child' ); dies_ok( sub{ $Parsed = Mail::AuthenticationResults::Parser->new()->parse( 'example.com; none dkim=pass' ) }, 'none with subentry dies' ); dies_ok( sub{ $Parsed = Mail::AuthenticationResults::Parser->new()->parse( 'example.com; none none' ) }, 'double none dies' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/04-outlook.t0000644000175000017500000000244514120352241020332 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; #outlook header is not to the expected spec #plan( skip_all => 'Outlook does not currently parse correctly' ); #my $ARHeader = 'Authentication-Results: spf=pass (sender IP is 66.111.4.222) # smtp.mailfrom=fastmail.com; outlook.com; dkim=pass (signature was verified) # header.d=fastmail.com;outlook.com; dmarc=pass action=none # header.from=fastmail.com;'; # Refactor the actual outlook.com header for the tests my $ARHeader = 'Authentication-Results: outlook.com; spf=pass (sender IP is 66.111.4.222) smtp.mailfrom=fastmail.com; outlook.com; dkim=pass (signature was verified) header.d=fastmail.com; dmarc=pass action=none header.from=fastmail.com;'; my $Parsed; lives_ok( sub{ $Parsed = Mail::AuthenticationResults::Parser->new()->parse( $ARHeader ) }, 'Parse lives' ); is ( $Parsed->value()->value(), 'outlook.com', 'ServID' ); is ( scalar @{$Parsed->search({ 'key'=>'spf','value'=>'pass' })->children() }, 1, 'SPF Pass' ); is ( scalar @{$Parsed->search({ 'key'=>'dkim','value'=>'pass' })->children() }, 1, 'DKIM Pass' ); is ( scalar @{$Parsed->search({ 'key'=>'dmarc','value'=>'pass' })->children() }, 1, 'DMARC Pass' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/02-parser.t0000644000175000017500000000500214120352241020120 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; #plan tests => noplan1; chdir 't'; my $Input = [ 'iprev=fail policy.iprev=123.123.123.123 (NOT FOUND)', 'x-ptr=fail x-ptr-helo=bad.name.google.com x-ptr-lookup=', 'spf=fail smtp.mailfrom=test@goestheweasel.com smtp.helo=bad.name.google.com', 'dkim=none (no signatures found)', 'x-google-dkim=none (no signatures found)', 'dmarc=fail (p=none,d=none) header.from=marcbradshaw.net', 'dmarc=fail (p=reject,d=reject) header.from=goestheweasel.com', 'dmarc=none (p=none,d=none) header.from=example.com' ]; my $Output = [ 'iprev=fail policy.iprev=123.123.123.123 (NOT FOUND)', 'x-ptr=fail x-ptr-helo=bad.name.google.com x-ptr-lookup=""', 'spf=fail smtp.mailfrom=test@goestheweasel.com smtp.helo=bad.name.google.com', 'dkim=none (no signatures found)', 'x-google-dkim=none (no signatures found)', 'dmarc=fail (p=none,d=none) header.from=marcbradshaw.net', 'dmarc=fail (p=reject,d=reject) header.from=goestheweasel.com', 'dmarc=none (p=none,d=none) header.from=example.com' ]; my $InputARHeader = join( ";\n", 'test.example.com', @$Input ); my $Parser; dies_ok( sub{ $Parser = Mail::AuthenticationResults::Parser->new()->parse( '' ) }, 'Parser dies on empty' ); lives_ok( sub{ $Parser = Mail::AuthenticationResults::Parser->new( $InputARHeader ) }, 'Parser parses' ); is( ref $Parser, 'Mail::AuthenticationResults::Parser', 'Returns Parser Object' ); my $Header; lives_ok( sub{ $Header = $Parser->parsed() }, 'Parser returns data' ); is( ref $Header, 'Mail::AuthenticationResults::Header', 'Returns Header Object' ); is( $Header->value()->value(), 'test.example.com', 'Authserve Id correct' ); is( $Header->as_string(), join( ";\n ", 'test.example.com', @$Output ), 'As String data matches input data' ); my $Search; lives_ok( sub{ $Search = $Header->search({ 'key'=>'dmarc','value'=>'none' }) }, 'Searches returns data' ); is( ref $Search, 'Mail::AuthenticationResults::Header::Group', 'Returns Header Group Object' ); is( $Search->as_string(), $Input->[7], 'As String data matches expected data' ); my $MultiSearch; lives_ok( sub{ $MultiSearch = $Header->search({ 'key'=>'dmarc' }) }, 'Searches returns data' ); is( ref $MultiSearch, 'Mail::AuthenticationResults::Header::Group', 'Returns Header Group Object' ); is( $MultiSearch->as_string(), join( ";\n", $Input->[5] , $Input->[6], $Input->[7] ), 'As String data matches expected data' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/02-parser-quoted.t0000644000175000017500000000353714120352241021432 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; #plan tests => noplan1; chdir 't'; my $Input = [ '"iprev"="fail" "policy"."iprev"="123.123.123.123" (NOT FOUND)', '"x-ptr"="fail" "x-ptr-helo"="bad.name.google.com" "x-ptr-lookup"=""', '"spf"="fail" "smtp.mailfrom"="test@goestheweasel.com" "smtp"."helo"="bad.name.google.com"', '"dkim"="none" (no signatures found)', '"x-google-dkim"="none" (no signatures found)', '"dmarc"="fail" (p=none,d=none) "header"."from"="marcbradshaw.net"', '"dmarc"="fail" (p=reject,d=reject) "header.from"="goestheweasel.com"', '"dmarc"="none" (p=none,d=none) "header"."from"="example.com"' ]; my $Output = [ 'iprev=fail policy.iprev=123.123.123.123 (NOT FOUND)', 'x-ptr=fail x-ptr-helo=bad.name.google.com x-ptr-lookup=""', 'spf=fail smtp.mailfrom=test@goestheweasel.com smtp.helo=bad.name.google.com', 'dkim=none (no signatures found)', 'x-google-dkim=none (no signatures found)', 'dmarc=fail (p=none,d=none) header.from=marcbradshaw.net', 'dmarc=fail (p=reject,d=reject) header.from=goestheweasel.com', 'dmarc=none (p=none,d=none) header.from=example.com' ]; my $InputARHeader = join( ";\n", '"test.example.com"', @$Input ); my $Parser; lives_ok( sub{ $Parser = Mail::AuthenticationResults::Parser->new( $InputARHeader ) }, 'Parser parses' ); is( ref $Parser, 'Mail::AuthenticationResults::Parser', 'Returns Parser Object' ); my $Header; lives_ok( sub{ $Header = $Parser->parsed() }, 'Parser returns data' ); is( ref $Header, 'Mail::AuthenticationResults::Header', 'Returns Header Object' ); is( $Header->value()->value(), 'test.example.com', 'Authserve Id correct' ); is( $Header->as_string(), join( ";\n ", 'test.example.com', @$Output ), 'As String data matches input data' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/03-add-children-from.t0000644000175000017500000000527414120352241022117 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; my $ARHeader1 = 'Authentication-Results: mx6.messagingengine.com; dkim=pass (1024-bit rsa key sha256) header.d=mail.ru header.i=@mail.ru header.b=oF80QtY/ x-bits=1024 x-keytype=rsa x-algorithm=sha256 x-selector=mail2; spf=pass smtp.mailfrom=fmdeliverability@mail.ru smtp.helo=smtp46.i.mail.ru;'; my $ARHeader2 = 'Authentication-Results: mx5.messagingengine.com; dmarc=pass (p=reject,d=none) header.from=mail.ru;'; my $Parsed1; my $Parsed2; lives_ok( sub{ $Parsed1 = Mail::AuthenticationResults::Parser->new()->parse( $ARHeader1 ) }, 'Parse 1 lives' ); lives_ok( sub{ $Parsed2 = Mail::AuthenticationResults::Parser->new()->parse( $ARHeader2 ) }, 'Parse 2 lives' ); is ( $Parsed1->value()->value(), 'mx6.messagingengine.com', 'ServID 1' ); is ( scalar @{$Parsed1->search({ 'key'=>'spf','value'=>'pass' })->children() }, 1, 'SPF Pass 1' ); is ( scalar @{$Parsed1->search({ 'key'=>'dkim','value'=>'pass' })->search({ 'key'=>'header.i','value'=>'@mail.ru' })->children() }, 1, 'DKIM Pass 1' ); is ( scalar @{$Parsed1->search({ 'key'=>'dmarc','value'=>'pass' })->children() }, 0, 'DMARC Missing 1' ); is ( $Parsed2->value()->value(), 'mx5.messagingengine.com', 'ServID 2' ); is ( scalar @{$Parsed2->search({ 'key'=>'spf','value'=>'pass' })->children() }, 0, 'SPF Missing 2' ); is ( scalar @{$Parsed2->search({ 'key'=>'dkim','value'=>'pass' })->search({ 'key'=>'header.i','value'=>'@mail.ru' })->children() }, 0, 'DKIM Missing 2' ); is ( scalar @{$Parsed2->search({ 'key'=>'dmarc','value'=>'pass' })->children() }, 1, 'DMARC Pass 2' ); lives_ok( sub{ $Parsed1->copy_children_from( $Parsed2 ) }, 'Merge 2 into 1 lives' ); is ( $Parsed1->value()->value(), 'mx6.messagingengine.com', 'ServID 1 post copy' ); is ( scalar @{$Parsed1->search({ 'key'=>'spf','value'=>'pass' })->children() }, 1, 'SPF Pass 1 post copy' ); is ( scalar @{$Parsed1->search({ 'key'=>'dkim','value'=>'pass' })->search({ 'key'=>'header.i','value'=>'@mail.ru' })->children() }, 1, 'DKIM Pass 1 post copy' ); is ( scalar @{$Parsed1->search({ 'key'=>'dmarc','value'=>'pass' })->children() }, 1, 'DMARC Pass post copy' ); is ( $Parsed2->value()->value(), 'mx5.messagingengine.com', 'ServID 2' ); is ( scalar @{$Parsed2->search({ 'key'=>'spf','value'=>'pass' })->children() }, 0, 'SPF Missing 2 post copy' ); is ( scalar @{$Parsed2->search({ 'key'=>'dkim','value'=>'pass' })->search({ 'key'=>'header.i','value'=>'@mail.ru' })->children() }, 0, 'DKIM Missing 2 post copy' ); is ( scalar @{$Parsed2->search({ 'key'=>'dmarc','value'=>'pass' })->children() }, 1, 'DMARC Pass 2 post copy' ); done_testing(); Mail-AuthenticationResults-2.20210915/t/05-as_string-wrap.t0000644000175000017500000000513314120352241021574 0ustar marcmarc#!perl use 5.008; use strict; use warnings FATAL => 'all'; use lib 't'; use Test::More; use Test::Exception; use lib 'lib'; use Mail::AuthenticationResults::Parser; my $InputARHeader = 'test.example.com; foo=bar string1=string string2=string string3=string string4=string string5=string string6=string'; subtest 'No folding' => sub{ my $Parser = Mail::AuthenticationResults::Parser->new( $InputARHeader ); my $Parsed = $Parser->parsed(); $Parsed->set_indent_style( 'none' ); is( $Parsed->as_string(), $InputARHeader, 'stringifies ok' ); }; subtest 'Set folding' => sub{ my $Parser = Mail::AuthenticationResults::Parser->new( $InputARHeader ); my $Parsed = $Parser->parsed(); is( $Parsed->fold_at(), undef, 'Fold at starts undefined' ); lives_ok( sub{ $Parsed->set_fold_at( 5 ); }, 'set_fold_at lives' ); is( $Parsed->fold_at(), 5, 'Fold at has been set' ); is( $Parsed->force_fold_at(), undef, 'Force fold at starts undefined' ); lives_ok( sub{ $Parsed->set_force_fold_at( 800 ); }, 'set_force_fold_at lives' ); is( $Parsed->force_fold_at(), 800, 'Force fold at has been set' ); }; subtest 'Extra Short folding' => sub{ my $Parser = Mail::AuthenticationResults::Parser->new( $InputARHeader ); my $Parsed = $Parser->parsed(); $Parsed->set_fold_at( 18 ); $Parsed->set_indent_style( 'entry' ); my $OutputARHeader = 'test.example.com; foo=bar string1= string string2= string string3= string string4= string string5= string string6= string'; is( $Parsed->as_string(), $OutputARHeader, 'stringifies ok' ); }; subtest 'Short folding' => sub{ my $Parser = Mail::AuthenticationResults::Parser->new( $InputARHeader ); my $Parsed = $Parser->parsed(); $Parsed->set_fold_at( 21 ); $Parsed->set_indent_style( 'entry' ); my $OutputARHeader = 'test.example.com; foo=bar string1=string string2=string string3=string string4=string string5=string string6=string'; is( $Parsed->as_string(), $OutputARHeader, 'stringifies ok' ); }; subtest 'Longer folding' => sub{ my $Parser = Mail::AuthenticationResults::Parser->new( $InputARHeader ); my $Parsed = $Parser->parsed(); $Parsed->set_fold_at( 40 ); $Parsed->set_indent_style( 'entry' ); my $OutputARHeader = 'test.example.com; foo=bar string1=string string2=string string3=string string4=string string5=string string6=string'; is( $Parsed->as_string(), $OutputARHeader, 'stringifies ok' ); }; # Force fold at is not currently implemented done_testing(); Mail-AuthenticationResults-2.20210915/dist.ini0000644000175000017500000000071114120352241017423 0ustar marcmarcname = Mail-AuthenticationResults author = Marc Bradshaw license = Perl_5 copyright_holder = Marc Bradshaw copyright_year = 2021 [@Basic] [AutoVersion] format = 2.{{ cldr('yyyyMMdd') }} [Git::Contributors] [ReadmeAnyFromPod / build] type=text filename=README location=build [OurPkgVersion] [NextRelease] [PodWeaver] [PodCoverageTests] [PodSyntaxTests] [Test::Perl::Critic] critic_config = t/perlcritic.rc [AutoPrereqs] Mail-AuthenticationResults-2.20210915/Makefile.PL0000644000175000017500000000254414120352241017737 0ustar marcmarc# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.017. use strict; use warnings; use 5.008; use ExtUtils::MakeMaker; my %WriteMakefileArgs = ( "ABSTRACT" => "Object Oriented Authentication-Results Headers", "AUTHOR" => "Marc Bradshaw ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => 0 }, "DISTNAME" => "Mail-AuthenticationResults", "LICENSE" => "perl", "MIN_PERL_VERSION" => "5.008", "NAME" => "Mail::AuthenticationResults", "PREREQ_PM" => { "Carp" => 0, "Clone" => 0, "JSON" => 0, "Scalar::Util" => 0, "base" => 0, "strict" => 0, "warnings" => 0 }, "TEST_REQUIRES" => { "Test::Exception" => 0, "Test::More" => 0, "lib" => 0 }, "VERSION" => "2.20210915", "test" => { "TESTS" => "t/*.t" } ); my %FallbackPrereqs = ( "Carp" => 0, "Clone" => 0, "JSON" => 0, "Scalar::Util" => 0, "Test::Exception" => 0, "Test::More" => 0, "base" => 0, "lib" => 0, "strict" => 0, "warnings" => 0 ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs);