Mail-AuthenticationResults-2.20260216000755001750001750 015144511503 16455 5ustar00useruser000000000000README100644001750001750 227115144511503 17420 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216NAME Mail::AuthenticationResults - Object Oriented Authentication-Results Headers VERSION version 2.20260216 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. Changes100644001750001750 467615144511503 20046 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216Change log for Mail::AuthenticationResults 2.20260216 2026-02-16 14:47:11+11:00 Australia/Melbourne - Added some helper methods which can be used to add commonly used children to an object. * $object->add_entry($key, $value); * $object->add_sub_entry($key, $value); * $object->add_comment($value); each returns the new object being added which can then be manipulated/added to as required. 2.20250709 2025-07-10 09:33:55+10:00 Australia/Melbourne - Correctly parse a string beginning with a slash 2.20231031 2023-10-31 23:57:33+00:00 UTC - Option to set more strict quoting of string 2.20230112 2023-01-12 22:49:04+00:00 UTC - Add parser method to parse json serialized object back into the object(s) it represents 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. LICENSE100644001750001750 4630415144511503 17572 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216This 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. 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, see . 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 Moe Ghoul, President of Vice That's all there is to it! --- The Perl Artistic License 1.0 --- This software is Copyright (c) 2021 by Marc Bradshaw. This is free software, licensed under: The Perl 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 as specified below. "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 uunet.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) give non-standard executables non-standard names, and clearly document 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. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 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 whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End dist.ini100644001750001750 71115144511503 20161 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216name = 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] META.yml100644001750001750 162115144511503 20007 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216--- 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.037, CPAN::Meta::Converter version 2.150012' 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.20260216' x_contributors: - 'Jemma Bradshaw ' - 'Marc Bradshaw ' - 'Ricardo Signes ' x_generated_by_perl: v5.42.0 x_serialization_backend: 'YAML::Tiny version 1.76' x_spdx_expression: 'Artistic-1.0-Perl OR GPL-1.0-or-later' MANIFEST100644001750001750 307715144511503 17676 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.037 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-helpers.t t/02-none.t t/02-parser-begin-dot.t t/02-parser-json.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 t/perlcritic.rc weaver.ini README.md100644001750001750 206215144511503 20015 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216# 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. weaver.ini100644001750001750 54115144511503 20510 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216[@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] t000755001750001750 015144511503 16641 5ustar00useruser000000000000Mail-AuthenticationResults-2.2026021604-aol.t100644001750001750 211115144511503 20155 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 02-get.t100644001750001750 472515144511503 20174 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 05-eol.t100644001750001750 212015144511503 20162 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 02-set.t100644001750001750 1462615144511503 20231 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 02-none.t100644001750001750 312615144511503 20346 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); Makefile.PL100644001750001750 254315144511503 20514 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.037 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.20260216", "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); 04-gmail.t100644001750001750 247715144511503 20512 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 04-yahoo.t100644001750001750 117715144511503 20534 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 03-search.t100644001750001750 430415144511503 20654 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 04-icloud.t100644001750001750 345615144511503 20676 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 04-yandex.t100644001750001750 162315144511503 20701 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 02-tokens.t100644001750001750 1160115144511503 20727 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 03-parser.t100644001750001750 1006015144511503 20717 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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' ); my $ParsedSlash; lives_ok( sub{ $ParsedSlash = Mail::AuthenticationResults::Parser->new()->parse( 'example.com; dkim=pass address=/somestring/orother') }, 'Slash parse lives' ); is( $ParsedSlash->children()->[0]->children->[0]->value(), '/somestring/orother', 'Slash value correct' ); is( $ParsedSlash->children()->[0]->children->[0]->as_string(), 'address=/somestring/orother', 'Slash value stringify correct' ); $ParsedSlash->set_strict_quotes(1); is( $ParsedSlash->children()->[0]->children->[0]->as_string(), 'address="/somestring/orother"', 'Slash value stringify correct in strict mode' ); dies_ok( sub{ Mail::AuthenticationResults::Parser->new()->parse( ';none' ) }, 'Missing AuthServ-ID dies' ); done_testing(); 02-parser.t100644001750001750 500215144511503 20676 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 04-mail.ru.t100644001750001750 233315144511503 20757 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 02-helpers.t100644001750001750 262715144511503 21056 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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; subtest helpers => sub{ my $header = Mail::AuthenticationResults::Header->new; lives_ok( sub { $header->add_entry(test => 'pass') }, 'can add entry to header' ); lives_ok( sub { $header->add_comment('this is a comment') }, 'can add comment to header' ); dies_ok( sub { $header->add_sub_entry(invalid => 'fail') }, 'cannot add sub entry to header' ); my $expected = "unknown;\n test=pass; (this is a comment)"; is($header->as_string, $expected, 'Stringifies as expected'); }; subtest helpers_deep => sub { my $header = Mail::AuthenticationResults::Header->new; my $entry = $header->add_entry(dkim => 'pass'); my $sub_entry = $entry->add_sub_entry(foo => 'bar'); my $comment = $sub_entry->add_comment('this is a comment'); my $expected = "unknown;\n dkim=pass foo=bar (this is a comment)"; is($header->as_string, $expected, 'Stringifies as expected'); }; done_testing;05-as-json.t100644001750001750 465715144511503 20776 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 04-outlook.t100644001750001750 244515144511503 21110 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 02-comment.t100644001750001750 554615144511503 21061 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 02-safe_set.t100644001750001750 1201315144511503 21213 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 02-children.t100644001750001750 2726215144511503 21226 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); perlcritic.rc100644001750001750 015144511503 21375 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t04-fastmail.t100644001750001750 274115144511503 21213 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 03-search-has.t100644001750001750 233215144511503 21424 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); author-critic.t100644001750001750 37115144511503 21724 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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", }}; all_critic_ok(); 02-parser-json.t100644001750001750 471615144511503 21660 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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 $JSON = $Parser->parsed()->as_json(); my $Header = Mail::AuthenticationResults::Parser->new()->from_authentication_results_json($JSON); 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(); 03-parser-bogus.t100644001750001750 206015144511503 22015 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 02-parser-quoted.t100644001750001750 353715144511503 22210 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 05-as_string-wrap.t100644001750001750 513315144511503 22352 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); author-pod-syntax.t100644001750001750 45315144511503 22556 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 02-parser-begin-dot.t100644001750001750 261315144511503 22551 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 05-as_string-styles.t100644001750001750 1045415144511503 22746 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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', 'x-url=http://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; x-url=http://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; x-url=http://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; x-url=http://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; x-url=http://example.com'; my $FullStrict = '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; x-url="http://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' ); is( $Parsed->set_indent_style( 'full' )->set_strict_quotes(1)->as_string(), $FullStrict, 'Full Strict stringifies correctly' ); dies_ok( sub{ $Parsed->set_indent_style( 'bogus_indent_style' ); }, 'invalid style dies' ); done_testing(); author-pod-coverage.t100644001750001750 56615144511503 23030 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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 strict; use warnings; use Test::Pod::Coverage 1.08; use Pod::Coverage::TrustPod; all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' }); 03-add-children-from.t100644001750001750 527415144511503 22675 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 03-search-authserv-id.t100644001750001750 333415144511503 23107 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); 05-parser-comment-heavy.t100644001750001750 157415144511503 23465 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/t#!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(); Mail000755001750001750 015144511503 20026 5ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/libAuthenticationResults.pm100644001750001750 322615144511503 25070 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mailpackage Mail::AuthenticationResults; # ABSTRACT: Object Oriented Authentication-Results Headers require 5.008; use strict; use warnings; our $VERSION = '2.20260216'; # 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.20260216 =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 AuthenticationResults000755001750001750 015144511503 24367 5ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/MailToken.pm100644001750001750 461015144511503 26146 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResultspackage Mail::AuthenticationResults::Token; # ABSTRACT: Base class for modelling AuthenticationResults Header parts require 5.008; use strict; use warnings; our $VERSION = '2.20260216'; # 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.20260216 =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 Header.pm100644001750001750 1743315144511503 26305 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResultspackage Mail::AuthenticationResults::Header; # ABSTRACT: Class modelling the Entire Authentication Results Header set require 5.008; use strict; use warnings; our $VERSION = '2.20260216'; # 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.20260216 =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 Parser.pm100644001750001750 3044215144511503 26344 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResultspackage Mail::AuthenticationResults::Parser; # ABSTRACT: Class for parsing Authentication Results Headers require 5.008; use strict; use warnings; our $VERSION = '2.20260216'; # 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; use JSON; 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 from_authentication_results_json { my ( $self, $json ) = @_; my $j = JSON->new(); my $hashref = $j->decode( $json ); return $self->_from_hashref( $hashref ); } sub _from_hashref { my ( $self, $hashref ) = @_; my $type = $hashref->{'type'}; my $object = $type eq 'header' ? Mail::AuthenticationResults::Header->new() : $type eq 'authservid' ? Mail::AuthenticationResults::Header::AuthServID->new() : $type eq 'entry' ? Mail::AuthenticationResults::Header::Entry->new() : $type eq 'subentry' ? Mail::AuthenticationResults::Header::SubEntry->new() : $type eq 'comment' ? Mail::AuthenticationResults::Header::Comment->new() : croak "unknown type $type"; if ( $type eq 'header' ) { my $authserv_id = $self->_from_hashref( $hashref->{ 'authserv_id' } ); $object->set_value( $authserv_id ); } else { $object->set_key( $hashref->{'key'} ) if exists $hashref->{'key'}; $object->safe_set_value( $hashref->{'value'} ) if exists $hashref->{'value'}; } if ( exists $hashref->{'children'} ) { for my $child ( @{ $hashref->{'children'} } ) { my $child_object = $self->_from_hashref( $child ); $object->add_child( $child_object ); } } return $object; } 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 ( $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; } 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.20260216 =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 from_authentication_results_json( $json ) Parse $json as the json returned from an as_json method call 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 Token000755001750001750 015144511503 25447 5ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResultsSpace.pm100644001750001750 214615144511503 27203 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResults/Tokenpackage Mail::AuthenticationResults::Token::Space; # ABSTRACT: Class for modelling AuthenticationResults Header parts detected as spaces require 5.008; use strict; use warnings; our $VERSION = '2.20260216'; # 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.20260216 =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 Header000755001750001750 015144511503 25557 5ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResultsBase.pm100644001750001750 4207215144511503 27154 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResults/Headerpackage 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.20260216'; # VERSION use Scalar::Util qw{ weaken refaddr }; use JSON; use Carp; use Clone qw{ clone }; use Mail::AuthenticationResults::Header::Group; use Mail::AuthenticationResults::FoldableHeader; use Mail::AuthenticationResults::Header::Entry; use Mail::AuthenticationResults::Header::SubEntry; use Mail::AuthenticationResults::Header::Comment; 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; my $strict_quotes = $self->strict_quotes; if ( ( $strict_quotes && $string =~ /[\s\t \(\);=<>@,:\\\/\[\]\?]/ ) || ( !$strict_quotes && $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 add_entry { my ($self, $key, $value) = @_; my $child = Mail::AuthenticationResults::Header::Entry->new->set_key($key)->safe_set_value($value); $self->add_child($child); return $child; } sub add_sub_entry { my ($self, $key, $value) = @_; my $child = Mail::AuthenticationResults::Header::SubEntry->new->set_key($key)->safe_set_value($value); $self->add_child($child); return $child; } sub add_comment { my ($self, $value) = @_; my $child = Mail::AuthenticationResults::Header::Comment->new->safe_set_value($value); $self->add_child($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 strict_quotes { my ( $self ) = @_; return $self->{ 'strict_quotes' } if defined $self->{ 'strict_quotes' }; my ( $eldest, $depth ) = $self->ancestor(); return 0 if $depth == 0; return $eldest->strict_quotes; } sub set_strict_quotes { my ( $self, $value ) = @_; $self->{ 'strict_quotes' } = $value ? 1 : 0; return $self; } 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.20260216 =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 add_entry ($key, $value) Creates a new entry with the given key and value, and then adds that as a child. Returns the child added. =head2 add_sub_entry ($self, $key, $value) Creates a new sub entry with the given key and value, and then adds that as a child. Returns the child added. =head2 add_comment ($key, $value) Creates a new comment with the given key and value, and then adds that as a child. Returns the child added. =head2 ancestor() Returns the top Header object and depth of this child =head2 strict_quotes() Return the current value of strict quotes flag for this header or for its ancestor if not set locally If true, we are stricter about which characters result in a quoted string =head2 set_strict_quotes( $value ) Set the value of strict quotes If true, we are stricter about which characters result in a quoted string Default false =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 String.pm100644001750001750 423115144511503 27413 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResults/Tokenpackage Mail::AuthenticationResults::Token::String; # ABSTRACT: Class for modelling AuthenticationResults Header parts detected as strings require 5.008; use strict; use warnings; our $VERSION = '2.20260216'; # 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.20260216 =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 Group.pm100644001750001750 501215144511503 27347 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResults/Headerpackage Mail::AuthenticationResults::Header::Group; # ABSTRACT: Class modelling Groups of Authentication Results Header parts require 5.008; use strict; use warnings; our $VERSION = '2.20260216'; # 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.20260216 =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 Entry.pm100644001750001750 275015144511503 27362 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResults/Headerpackage 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.20260216'; # 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.20260216 =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 Comment.pm100644001750001750 312115144511503 27544 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResults/Tokenpackage Mail::AuthenticationResults::Token::Comment; # ABSTRACT: Class for modelling AuthenticationResults Header parts detected as comments require 5.008; use strict; use warnings; our $VERSION = '2.20260216'; # 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.20260216 =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 FoldableHeader.pm100644001750001750 2173115144511503 27732 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResultspackage Mail::AuthenticationResults::FoldableHeader; # ABSTRACT: Class for modelling a foldable header string require 5.008; use strict; use warnings; our $VERSION = '2.20260216'; # 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.20260216 =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 Version.pm100644001750001750 350415144511503 27704 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResults/Headerpackage 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.20260216'; # 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.20260216 =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 Comment.pm100644001750001750 467315144511503 27671 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResults/Headerpackage Mail::AuthenticationResults::Header::Comment; # ABSTRACT: Class modelling Comment parts of the Authentication Results Header require 5.008; use strict; use warnings; our $VERSION = '2.20260216'; # 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.20260216 =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 Separator.pm100644001750001750 224415144511503 30107 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResults/Tokenpackage Mail::AuthenticationResults::Token::Separator; # ABSTRACT: Class for modelling AuthenticationResults Header parts detected as separators require 5.008; use strict; use warnings; our $VERSION = '2.20260216'; # 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.20260216 =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 SubEntry.pm100644001750001750 254315144511503 30034 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResults/Headerpackage 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.20260216'; # 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.20260216 =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 Assignment.pm100644001750001750 235715144511503 30264 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResults/Tokenpackage Mail::AuthenticationResults::Token::Assignment; # ABSTRACT: Class for modelling AuthenticationResults Header parts detected as assignments require 5.008; use strict; use warnings; our $VERSION = '2.20260216'; # 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.20260216 =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 AuthServID.pm100644001750001750 373615144511503 30244 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResults/Headerpackage 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.20260216'; # 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.20260216 =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 QuotedString.pm100644001750001750 275515144511503 30606 0ustar00useruser000000000000Mail-AuthenticationResults-2.20260216/lib/Mail/AuthenticationResults/Tokenpackage 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.20260216'; # 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.20260216 =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