From 03bcac18fb7e0e84879f5f66fc89a3e5adfb76d6 Mon Sep 17 00:00:00 2001 From: Charles McGarvey Date: Sat, 30 Apr 2022 21:15:10 -0600 Subject: [PATCH 1/1] Version 0.800 --- Changes | 6 + LICENSE | 379 ++++ MANIFEST | 115 + META.json | 339 +++ META.yml | 217 ++ Makefile.PL | 138 ++ README | 1605 ++++++++++++++ lib/File/KDBX.pm | 2807 ++++++++++++++++++++++++ lib/File/KDBX/Cipher.pm | 378 ++++ lib/File/KDBX/Cipher/CBC.pm | 98 + lib/File/KDBX/Cipher/Stream.pm | 194 ++ lib/File/KDBX/Constants.pm | 1002 +++++++++ lib/File/KDBX/Dumper.pm | 442 ++++ lib/File/KDBX/Dumper/KDB.pm | 179 ++ lib/File/KDBX/Dumper/Raw.pm | 97 + lib/File/KDBX/Dumper/V3.pm | 214 ++ lib/File/KDBX/Dumper/V4.pm | 402 ++++ lib/File/KDBX/Dumper/XML.pm | 646 ++++++ lib/File/KDBX/Entry.pm | 1687 ++++++++++++++ lib/File/KDBX/Error.pm | 276 +++ lib/File/KDBX/Group.pm | 721 ++++++ lib/File/KDBX/IO.pm | 461 ++++ lib/File/KDBX/IO/Crypt.pm | 200 ++ lib/File/KDBX/IO/HashBlock.pm | 286 +++ lib/File/KDBX/IO/HmacBlock.pm | 288 +++ lib/File/KDBX/Iterator.pm | 462 ++++ lib/File/KDBX/KDF.pm | 256 +++ lib/File/KDBX/KDF/AES.pm | 157 ++ lib/File/KDBX/KDF/Argon2.pm | 121 + lib/File/KDBX/Key.pm | 293 +++ lib/File/KDBX/Key/ChallengeResponse.pm | 122 + lib/File/KDBX/Key/Composite.pm | 156 ++ lib/File/KDBX/Key/File.pm | 402 ++++ lib/File/KDBX/Key/Password.pm | 74 + lib/File/KDBX/Key/YubiKey.pm | 513 +++++ lib/File/KDBX/Loader.pm | 422 ++++ lib/File/KDBX/Loader/KDB.pm | 443 ++++ lib/File/KDBX/Loader/Raw.pm | 86 + lib/File/KDBX/Loader/V3.pm | 200 ++ lib/File/KDBX/Loader/V4.pm | 300 +++ lib/File/KDBX/Loader/XML.pm | 616 ++++++ lib/File/KDBX/Object.pm | 937 ++++++++ lib/File/KDBX/Safe.pm | 338 +++ lib/File/KDBX/Transaction.pm | 111 + lib/File/KDBX/Util.pm | 1224 +++++++++++ perlcritic.rc | 4 + t/00-compile.t | 97 + t/00-report-prereqs.dd | 110 + t/00-report-prereqs.t | 193 ++ t/crypt.t | 82 + t/database.t | 173 ++ t/entry.t | 172 ++ t/erase.t | 47 + t/error.t | 105 + t/files/BrokenHeaderHash.kdbx | Bin 0 -> 1982 bytes t/files/CP-1252.kdb | Bin 0 -> 620 bytes t/files/CompositeKey.kdb | Bin 0 -> 636 bytes t/files/Compressed.kdbx | Bin 0 -> 1982 bytes t/files/FileKeyBinary.kdb | Bin 0 -> 636 bytes t/files/FileKeyBinary.kdbx | Bin 0 -> 1582 bytes t/files/FileKeyBinary.key | 1 + t/files/FileKeyHashed.kdb | Bin 0 -> 636 bytes t/files/FileKeyHashed.kdbx | Bin 0 -> 1582 bytes t/files/FileKeyHashed.key | Bin 0 -> 1696 bytes t/files/FileKeyHex.kdb | Bin 0 -> 636 bytes t/files/FileKeyHex.kdbx | Bin 0 -> 1614 bytes t/files/FileKeyHex.key | 1 + t/files/Format200.kdbx | Bin 0 -> 2302 bytes t/files/Format300.kdbx | Bin 0 -> 2014 bytes t/files/Format400.kdbx | Bin 0 -> 1801 bytes t/files/MemoryProtection.kdbx | Bin 0 -> 2053 bytes t/files/NonAscii.kdbx | Bin 0 -> 2862 bytes t/files/ProtectedStrings.kdbx | Bin 0 -> 1998 bytes t/files/Twofish.kdb | Bin 0 -> 620 bytes t/files/basic.kdb | Bin 0 -> 2476 bytes t/files/bin/ykchalresp | 55 + t/files/bin/ykinfo | 37 + t/files/keys/binary.key | 1 + t/files/keys/hashed.key | 1 + t/files/keys/hex.key | 1 + t/files/keys/xmlv1.key | 11 + t/files/keys/xmlv2.key | 12 + t/group.t | 22 + t/hash-block.t | 70 + t/hmac-block.t | 74 + t/iterator.t | 101 + t/kdb.t | 199 ++ t/kdbx2.t | 100 + t/kdbx3.t | 133 ++ t/kdbx4.t | 219 ++ t/kdf-aes-pp.t | 27 + t/kdf.t | 45 + t/keys.t | 124 ++ t/lib/TestCommon.pm | 101 + t/memory-protection.t | 305 +++ t/object.t | 179 ++ t/otp.t | 165 ++ t/placeholders.t | 77 + t/query.t | 217 ++ t/references.t | 52 + t/safe.t | 62 + t/util.t | 135 ++ t/yubikey.t | 87 + xt/author/clean-namespaces.t | 16 + xt/author/critic.t | 7 + xt/author/distmeta.t | 6 + xt/author/eol.t | 93 + xt/author/minimum-version.t | 6 + xt/author/no-tabs.t | 93 + xt/author/pod-coverage.t | 7 + xt/author/pod-no404s.t | 21 + xt/author/pod-syntax.t | 7 + xt/author/portability.t | 10 + xt/release/cpan-changes.t | 10 + 114 files changed, 24283 insertions(+) create mode 100644 Changes create mode 100644 LICENSE create mode 100644 MANIFEST create mode 100644 META.json create mode 100644 META.yml create mode 100644 Makefile.PL create mode 100644 README create mode 100644 lib/File/KDBX.pm create mode 100644 lib/File/KDBX/Cipher.pm create mode 100644 lib/File/KDBX/Cipher/CBC.pm create mode 100644 lib/File/KDBX/Cipher/Stream.pm create mode 100644 lib/File/KDBX/Constants.pm create mode 100644 lib/File/KDBX/Dumper.pm create mode 100644 lib/File/KDBX/Dumper/KDB.pm create mode 100644 lib/File/KDBX/Dumper/Raw.pm create mode 100644 lib/File/KDBX/Dumper/V3.pm create mode 100644 lib/File/KDBX/Dumper/V4.pm create mode 100644 lib/File/KDBX/Dumper/XML.pm create mode 100644 lib/File/KDBX/Entry.pm create mode 100644 lib/File/KDBX/Error.pm create mode 100644 lib/File/KDBX/Group.pm create mode 100644 lib/File/KDBX/IO.pm create mode 100644 lib/File/KDBX/IO/Crypt.pm create mode 100644 lib/File/KDBX/IO/HashBlock.pm create mode 100644 lib/File/KDBX/IO/HmacBlock.pm create mode 100644 lib/File/KDBX/Iterator.pm create mode 100644 lib/File/KDBX/KDF.pm create mode 100644 lib/File/KDBX/KDF/AES.pm create mode 100644 lib/File/KDBX/KDF/Argon2.pm create mode 100644 lib/File/KDBX/Key.pm create mode 100644 lib/File/KDBX/Key/ChallengeResponse.pm create mode 100644 lib/File/KDBX/Key/Composite.pm create mode 100644 lib/File/KDBX/Key/File.pm create mode 100644 lib/File/KDBX/Key/Password.pm create mode 100644 lib/File/KDBX/Key/YubiKey.pm create mode 100644 lib/File/KDBX/Loader.pm create mode 100644 lib/File/KDBX/Loader/KDB.pm create mode 100644 lib/File/KDBX/Loader/Raw.pm create mode 100644 lib/File/KDBX/Loader/V3.pm create mode 100644 lib/File/KDBX/Loader/V4.pm create mode 100644 lib/File/KDBX/Loader/XML.pm create mode 100644 lib/File/KDBX/Object.pm create mode 100644 lib/File/KDBX/Safe.pm create mode 100644 lib/File/KDBX/Transaction.pm create mode 100644 lib/File/KDBX/Util.pm create mode 100644 perlcritic.rc create mode 100644 t/00-compile.t create mode 100644 t/00-report-prereqs.dd create mode 100644 t/00-report-prereqs.t create mode 100644 t/crypt.t create mode 100644 t/database.t create mode 100644 t/entry.t create mode 100644 t/erase.t create mode 100644 t/error.t create mode 100644 t/files/BrokenHeaderHash.kdbx create mode 100644 t/files/CP-1252.kdb create mode 100644 t/files/CompositeKey.kdb create mode 100644 t/files/Compressed.kdbx create mode 100644 t/files/FileKeyBinary.kdb create mode 100644 t/files/FileKeyBinary.kdbx create mode 100644 t/files/FileKeyBinary.key create mode 100644 t/files/FileKeyHashed.kdb create mode 100644 t/files/FileKeyHashed.kdbx create mode 100644 t/files/FileKeyHashed.key create mode 100644 t/files/FileKeyHex.kdb create mode 100644 t/files/FileKeyHex.kdbx create mode 100644 t/files/FileKeyHex.key create mode 100644 t/files/Format200.kdbx create mode 100644 t/files/Format300.kdbx create mode 100644 t/files/Format400.kdbx create mode 100644 t/files/MemoryProtection.kdbx create mode 100644 t/files/NonAscii.kdbx create mode 100644 t/files/ProtectedStrings.kdbx create mode 100644 t/files/Twofish.kdb create mode 100644 t/files/basic.kdb create mode 100755 t/files/bin/ykchalresp create mode 100755 t/files/bin/ykinfo create mode 100644 t/files/keys/binary.key create mode 100644 t/files/keys/hashed.key create mode 100644 t/files/keys/hex.key create mode 100644 t/files/keys/xmlv1.key create mode 100644 t/files/keys/xmlv2.key create mode 100644 t/group.t create mode 100644 t/hash-block.t create mode 100644 t/hmac-block.t create mode 100644 t/iterator.t create mode 100644 t/kdb.t create mode 100644 t/kdbx2.t create mode 100644 t/kdbx3.t create mode 100644 t/kdbx4.t create mode 100644 t/kdf-aes-pp.t create mode 100644 t/kdf.t create mode 100644 t/keys.t create mode 100644 t/lib/TestCommon.pm create mode 100644 t/memory-protection.t create mode 100644 t/object.t create mode 100644 t/otp.t create mode 100644 t/placeholders.t create mode 100644 t/query.t create mode 100644 t/references.t create mode 100644 t/safe.t create mode 100644 t/util.t create mode 100644 t/yubikey.t create mode 100644 xt/author/clean-namespaces.t create mode 100644 xt/author/critic.t create mode 100644 xt/author/distmeta.t create mode 100644 xt/author/eol.t create mode 100644 xt/author/minimum-version.t create mode 100644 xt/author/no-tabs.t create mode 100644 xt/author/pod-coverage.t create mode 100644 xt/author/pod-no404s.t create mode 100644 xt/author/pod-syntax.t create mode 100644 xt/author/portability.t create mode 100644 xt/release/cpan-changes.t diff --git a/Changes b/Changes new file mode 100644 index 0000000..9612e3c --- /dev/null +++ b/Changes @@ -0,0 +1,6 @@ +Revision history for File-KDBX. + +0.800 2022-04-30 21:14:30-0600 + + * Initial release + diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..c66d7e9 --- /dev/null +++ b/LICENSE @@ -0,0 +1,379 @@ +This software is copyright (c) 2022 by Charles McGarvey. + +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) 2022 by Charles McGarvey. + +This is free software, licensed under: + + The GNU General Public License, Version 1, February 1989 + + GNU GENERAL PUBLIC LICENSE + Version 1, February 1989 + + Copyright (C) 1989 Free Software Foundation, Inc. + 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The license agreements of most software companies try to keep users +at the mercy of those companies. By contrast, our General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. The +General Public License applies to the Free Software Foundation's +software and to any other program whose authors commit to using it. +You can use it for your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Specifically, the General Public License is designed to make +sure that you have the freedom to give away or sell copies of free +software, that you receive source code or can get it if you want it, +that you can change the software or use pieces of it in new free +programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of a such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must tell them their rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any program or other work which +contains a notice placed by the copyright holder saying it may be +distributed under the terms of this General Public License. The +"Program", below, refers to any such program or work, and a "work based +on the Program" means either the Program or any work containing the +Program or a portion of it, either verbatim or with modifications. Each +licensee is addressed as "you". + + 1. You may copy and distribute verbatim copies of the Program's source +code as you receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice and +disclaimer of warranty; keep intact all the notices that refer to this +General Public License and to the absence of any warranty; and give any +other recipients of the Program a copy of this General Public License +along with the Program. You may charge a fee for the physical act of +transferring a copy. + + 2. You may modify your copy or copies of the Program or any portion of +it, and copy and distribute such modifications under the terms of Paragraph +1 above, provided that you also do the following: + + a) cause the modified files to carry prominent notices stating that + you changed the files and the date of any change; and + + b) cause the whole of any work that you distribute or publish, that + in whole or in part contains the Program or any part thereof, either + with or without modifications, to be licensed at no charge to all + third parties under the terms of this General Public License (except + that you may choose to grant warranty protection to some or all + third parties, at your option). + + c) If the modified program normally reads commands interactively when + run, you must cause it, when started running for such interactive use + in the simplest and most usual way, to print or display an + announcement including an appropriate copyright notice and a notice + that there is no warranty (or else, saying that you provide a + warranty) and that users may redistribute the program under these + conditions, and telling the user how to view a copy of this General + Public License. + + d) You may charge a fee for the physical act of transferring a + copy, and you may at your option offer warranty protection in + exchange for a fee. + +Mere aggregation of another independent work with the Program (or its +derivative) on a volume of a storage or distribution medium does not bring +the other work under the scope of these terms. + + 3. You may copy and distribute the Program (or a portion or derivative of +it, under Paragraph 2) in object code or executable form under the terms of +Paragraphs 1 and 2 above provided that you also do one of the following: + + a) accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of + Paragraphs 1 and 2 above; or, + + b) accompany it with a written offer, valid for at least three + years, to give any third party free (except for a nominal charge + for the cost of distribution) a complete machine-readable copy of the + corresponding source code, to be distributed under the terms of + Paragraphs 1 and 2 above; or, + + c) accompany it with the information you received as to where the + corresponding source code may be obtained. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form alone.) + +Source code for a work means the preferred form of the work for making +modifications to it. For an executable file, complete source code means +all the source code for all modules it contains; but, as a special +exception, it need not include source code for modules which are standard +libraries that accompany the operating system on which the executable +file runs, or for standard header files or definitions files that +accompany that operating system. + + 4. You may not copy, modify, sublicense, distribute or transfer the +Program except as expressly provided under this General Public License. +Any attempt otherwise to copy, modify, sublicense, distribute or transfer +the Program is void, and will automatically terminate your rights to use +the Program under this License. However, parties who have received +copies, or rights to use copies, from you under this General Public +License will not have their licenses terminated so long as such parties +remain in full compliance. + + 5. By copying, distributing or modifying the Program (or any work based +on the Program) you indicate your acceptance of this license to do so, +and all its terms and conditions. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the original +licensor to copy, distribute or modify the Program subject to these +terms and conditions. You may not impose any further restrictions on the +recipients' exercise of the rights granted herein. + + 7. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of the license which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +the license, you may choose any version ever published by the Free Software +Foundation. + + 8. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to humanity, the best way to achieve this is to make it +free software which everyone can redistribute and change under these +terms. + + To do so, attach the following notices to the program. It is safest to +attach them to the start of each source file to most effectively convey +the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 1, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19xx name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the +appropriate parts of the General Public License. Of course, the +commands you use may be called something other than `show w' and `show +c'; they could even be mouse-clicks or menu items--whatever suits your +program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + program `Gnomovision' (a program to direct compilers to make passes + at assemblers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +That's all there is to it! + + +--- The Artistic License 1.0 --- + +This software is Copyright (c) 2022 by Charles McGarvey. + +This is free software, licensed under: + + The Artistic License 1.0 + +The Artistic License + +Preamble + +The intent of this document is to state the conditions under which a Package +may be copied, such that the Copyright Holder maintains some semblance of +artistic control over the development of the package, while giving the users of +the package the right to use and distribute the Package in a more-or-less +customary fashion, plus the right to make reasonable modifications. + +Definitions: + + - "Package" refers to the collection of files distributed by the Copyright + Holder, and derivatives of that collection of files created through + textual modification. + - "Standard Version" refers to such a Package if it has not been modified, + or has been modified in accordance with the wishes of the Copyright + Holder. + - "Copyright Holder" is whoever is named in the copyright or copyrights for + the package. + - "You" is you, if you're thinking about copying or distributing this Package. + - "Reasonable copying fee" is whatever you can justify on the basis of media + cost, duplication charges, time of people involved, and so on. (You will + not be required to justify it to the Copyright Holder, but only to the + computing community at large as a market that must bear the fee.) + - "Freely Available" means that no fee is charged for the item itself, though + there may be fees involved in handling the item. It also means that + recipients of the item may redistribute it under the same conditions they + received it. + +1. You may make and give away verbatim copies of the source form of the +Standard Version of this Package without restriction, provided that you +duplicate all of the original copyright notices and associated disclaimers. + +2. You may apply bug fixes, portability fixes and other modifications derived +from the Public Domain or from the Copyright Holder. A Package modified in such +a way shall still be considered the Standard Version. + +3. You may otherwise modify your copy of this Package in any way, provided that +you insert a prominent notice in each changed file stating how and when you +changed that file, and provided that you do at least ONE of the following: + + a) place your modifications in the Public Domain or otherwise make them + Freely Available, such as by posting said modifications to Usenet or an + equivalent medium, or placing the modifications on a major archive site + such as ftp.uu.net, or by allowing the Copyright Holder to include your + modifications in the Standard Version of the Package. + + b) use the modified Package only within your corporation or organization. + + c) rename any non-standard executables so the names do not conflict with + standard executables, which must also be provided, and provide a separate + manual page for each non-standard executable that clearly documents how it + differs from the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + +4. You may distribute the programs of this Package in object code or executable +form, provided that you do at least ONE of the following: + + a) distribute a Standard Version of the executables and library files, + together with instructions (in the manual page or equivalent) on where to + get the Standard Version. + + b) accompany the distribution with the machine-readable source of the Package + with your modifications. + + c) accompany any non-standard executables with their corresponding Standard + Version executables, giving the non-standard executables non-standard + names, and clearly documenting the differences in manual pages (or + equivalent), together with instructions on where to get the Standard + Version. + + d) make other distribution arrangements with the Copyright Holder. + +5. You may charge a reasonable copying fee for any distribution of this +Package. You may charge any fee you choose for support of this Package. You +may not charge a fee for this Package itself. However, you may distribute this +Package in aggregate with other (possibly commercial) programs as part of a +larger (possibly commercial) software distribution provided that you do not +advertise this Package as a product of your own. + +6. The scripts and library files supplied as input to or produced as output +from the programs of this Package do not automatically fall under the copyright +of this Package, but belong to whomever generated them, and may be sold +commercially, and may be aggregated with this Package. + +7. C or perl subroutines supplied by you and linked into this Package shall not +be considered part of this Package. + +8. The name of the Copyright Holder may not be used to endorse or promote +products derived from this software without specific prior written permission. + +9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED +WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. + +The End + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..5510691 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,115 @@ +# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.024. +Changes +LICENSE +MANIFEST +META.json +META.yml +Makefile.PL +README +lib/File/KDBX.pm +lib/File/KDBX/Cipher.pm +lib/File/KDBX/Cipher/CBC.pm +lib/File/KDBX/Cipher/Stream.pm +lib/File/KDBX/Constants.pm +lib/File/KDBX/Dumper.pm +lib/File/KDBX/Dumper/KDB.pm +lib/File/KDBX/Dumper/Raw.pm +lib/File/KDBX/Dumper/V3.pm +lib/File/KDBX/Dumper/V4.pm +lib/File/KDBX/Dumper/XML.pm +lib/File/KDBX/Entry.pm +lib/File/KDBX/Error.pm +lib/File/KDBX/Group.pm +lib/File/KDBX/IO.pm +lib/File/KDBX/IO/Crypt.pm +lib/File/KDBX/IO/HashBlock.pm +lib/File/KDBX/IO/HmacBlock.pm +lib/File/KDBX/Iterator.pm +lib/File/KDBX/KDF.pm +lib/File/KDBX/KDF/AES.pm +lib/File/KDBX/KDF/Argon2.pm +lib/File/KDBX/Key.pm +lib/File/KDBX/Key/ChallengeResponse.pm +lib/File/KDBX/Key/Composite.pm +lib/File/KDBX/Key/File.pm +lib/File/KDBX/Key/Password.pm +lib/File/KDBX/Key/YubiKey.pm +lib/File/KDBX/Loader.pm +lib/File/KDBX/Loader/KDB.pm +lib/File/KDBX/Loader/Raw.pm +lib/File/KDBX/Loader/V3.pm +lib/File/KDBX/Loader/V4.pm +lib/File/KDBX/Loader/XML.pm +lib/File/KDBX/Object.pm +lib/File/KDBX/Safe.pm +lib/File/KDBX/Transaction.pm +lib/File/KDBX/Util.pm +perlcritic.rc +t/00-compile.t +t/00-report-prereqs.dd +t/00-report-prereqs.t +t/crypt.t +t/database.t +t/entry.t +t/erase.t +t/error.t +t/files/BrokenHeaderHash.kdbx +t/files/CP-1252.kdb +t/files/CompositeKey.kdb +t/files/Compressed.kdbx +t/files/FileKeyBinary.kdb +t/files/FileKeyBinary.kdbx +t/files/FileKeyBinary.key +t/files/FileKeyHashed.kdb +t/files/FileKeyHashed.kdbx +t/files/FileKeyHashed.key +t/files/FileKeyHex.kdb +t/files/FileKeyHex.kdbx +t/files/FileKeyHex.key +t/files/Format200.kdbx +t/files/Format300.kdbx +t/files/Format400.kdbx +t/files/MemoryProtection.kdbx +t/files/NonAscii.kdbx +t/files/ProtectedStrings.kdbx +t/files/Twofish.kdb +t/files/basic.kdb +t/files/bin/ykchalresp +t/files/bin/ykinfo +t/files/keys/binary.key +t/files/keys/hashed.key +t/files/keys/hex.key +t/files/keys/xmlv1.key +t/files/keys/xmlv2.key +t/group.t +t/hash-block.t +t/hmac-block.t +t/iterator.t +t/kdb.t +t/kdbx2.t +t/kdbx3.t +t/kdbx4.t +t/kdf-aes-pp.t +t/kdf.t +t/keys.t +t/lib/TestCommon.pm +t/memory-protection.t +t/object.t +t/otp.t +t/placeholders.t +t/query.t +t/references.t +t/safe.t +t/util.t +t/yubikey.t +xt/author/clean-namespaces.t +xt/author/critic.t +xt/author/distmeta.t +xt/author/eol.t +xt/author/minimum-version.t +xt/author/no-tabs.t +xt/author/pod-coverage.t +xt/author/pod-no404s.t +xt/author/pod-syntax.t +xt/author/portability.t +xt/release/cpan-changes.t diff --git a/META.json b/META.json new file mode 100644 index 0000000..a1eb8ad --- /dev/null +++ b/META.json @@ -0,0 +1,339 @@ +{ + "abstract" : "Encrypted database to store secret text and files", + "author" : [ + "Charles McGarvey " + ], + "dynamic_config" : 0, + "generated_by" : "Dist::Zilla version 6.024, CPAN::Meta::Converter version 2.150010", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : 2 + }, + "name" : "File-KDBX", + "no_index" : { + "directory" : [ + "eg", + "share", + "shares", + "t", + "xt" + ] + }, + "optional_features" : { + "compression" : { + "description" : "ability to read and write compressed KDBX files", + "prereqs" : { + "runtime" : { + "requires" : { + "Compress::Raw::Zlib" : "0", + "IO::Compress::Gzip" : "0", + "IO::Uncompress::Gunzip" : "0" + } + } + } + }, + "otp" : { + "description" : "ability to generate one-time passwords from configured database entries", + "prereqs" : { + "runtime" : { + "requires" : { + "Pass::OTP" : "0" + } + } + } + }, + "xs" : { + "description" : "speed improvements (requires C compiler)", + "prereqs" : { + "runtime" : { + "requires" : { + "File::KDBX::XS" : "0" + } + } + } + } + }, + "prereqs" : { + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "develop" : { + "requires" : { + "Compress::Raw::Zlib" : "0", + "Dist::Zilla" : "5", + "Dist::Zilla::Plugin::Encoding" : "0", + "Dist::Zilla::Plugin::OptionalFeature" : "0", + "Dist::Zilla::Plugin::Prereqs" : "0", + "Dist::Zilla::Plugin::Prereqs::Soften" : "0", + "Dist::Zilla::PluginBundle::Author::CCM" : "0", + "File::KDBX::XS" : "0", + "IO::Compress::Gzip" : "0", + "IO::Uncompress::Gunzip" : "0", + "Pass::OTP" : "0", + "Pod::Coverage::TrustPod" : "0", + "Software::License::Perl_5" : "0", + "Test::CPAN::Changes" : "0.19", + "Test::CPAN::Meta" : "0", + "Test::CleanNamespaces" : "0.15", + "Test::EOL" : "0", + "Test::MinimumVersion" : "0", + "Test::More" : "0.96", + "Test::NoTabs" : "0", + "Test::Perl::Critic" : "0", + "Test::Pod" : "1.41", + "Test::Pod::Coverage" : "1.08", + "Test::Pod::No404s" : "0", + "Test::Portability::Files" : "0" + } + }, + "runtime" : { + "recommends" : { + "Compress::Raw::Zlib" : "0", + "File::KDBX::XS" : "0", + "File::Spec" : "0", + "IO::Compress::Gzip" : "0", + "IO::Uncompress::Gunzip" : "0", + "Pass::OTP" : "0" + }, + "requires" : { + "Carp" : "0", + "Crypt::Argon2" : "0", + "Crypt::Cipher" : "0", + "Crypt::Digest" : "0", + "Crypt::Mac::HMAC" : "0", + "Crypt::Misc" : "0.029", + "Crypt::Mode::CBC" : "0", + "Crypt::PRNG" : "0", + "Data::Dumper" : "0", + "Devel::GlobalDestruction" : "0", + "Encode" : "0", + "Exporter" : "0", + "File::Temp" : "0", + "Hash::Util::FieldHash" : "0", + "IO::Handle" : "0", + "IPC::Cmd" : "0.52", + "Iterator::Simple" : "0", + "Iterator::Simple::Iterator" : "0", + "List::Util" : "1.33", + "Module::Load" : "0", + "Module::Loaded" : "0", + "POSIX" : "0", + "Ref::Util" : "0", + "Scalar::Util" : "0", + "Scope::Guard" : "0", + "Storable" : "0", + "Symbol" : "0", + "Text::ParseWords" : "0", + "Time::Piece" : "0", + "XML::LibXML" : "0", + "XML::LibXML::Reader" : "0", + "boolean" : "0", + "namespace::clean" : "0", + "overload" : "0", + "strict" : "0", + "warnings" : "0" + } + }, + "test" : { + "recommends" : { + "CPAN::Meta" : "2.120900", + "Pass::OTP" : "0" + }, + "requires" : { + "ExtUtils::MakeMaker" : "0", + "File::Spec" : "0", + "FindBin" : "0", + "Getopt::Std" : "0", + "IO::Handle" : "0", + "IPC::Open3" : "0", + "Test::Deep" : "0", + "Test::Fatal" : "0", + "Test::More" : "0", + "Test::Warnings" : "0", + "lib" : "0", + "perl" : "5.006", + "utf8" : "0" + }, + "suggests" : { + "POSIX::1003" : "0" + } + } + }, + "provides" : { + "File::KDBX" : { + "file" : "lib/File/KDBX.pm", + "version" : "0.800" + }, + "File::KDBX::Cipher" : { + "file" : "lib/File/KDBX/Cipher.pm", + "version" : "0.800" + }, + "File::KDBX::Cipher::CBC" : { + "file" : "lib/File/KDBX/Cipher/CBC.pm", + "version" : "0.800" + }, + "File::KDBX::Cipher::Stream" : { + "file" : "lib/File/KDBX/Cipher/Stream.pm", + "version" : "0.800" + }, + "File::KDBX::Constants" : { + "file" : "lib/File/KDBX/Constants.pm", + "version" : "0.800" + }, + "File::KDBX::Dumper" : { + "file" : "lib/File/KDBX/Dumper.pm", + "version" : "0.800" + }, + "File::KDBX::Dumper::KDB" : { + "file" : "lib/File/KDBX/Dumper/KDB.pm", + "version" : "0.800" + }, + "File::KDBX::Dumper::Raw" : { + "file" : "lib/File/KDBX/Dumper/Raw.pm", + "version" : "0.800" + }, + "File::KDBX::Dumper::V3" : { + "file" : "lib/File/KDBX/Dumper/V3.pm", + "version" : "0.800" + }, + "File::KDBX::Dumper::V4" : { + "file" : "lib/File/KDBX/Dumper/V4.pm", + "version" : "0.800" + }, + "File::KDBX::Dumper::XML" : { + "file" : "lib/File/KDBX/Dumper/XML.pm", + "version" : "0.800" + }, + "File::KDBX::Entry" : { + "file" : "lib/File/KDBX/Entry.pm", + "version" : "0.800" + }, + "File::KDBX::Error" : { + "file" : "lib/File/KDBX/Error.pm", + "version" : "0.800" + }, + "File::KDBX::Group" : { + "file" : "lib/File/KDBX/Group.pm", + "version" : "0.800" + }, + "File::KDBX::IO" : { + "file" : "lib/File/KDBX/IO.pm", + "version" : "0.800" + }, + "File::KDBX::IO::Crypt" : { + "file" : "lib/File/KDBX/IO/Crypt.pm", + "version" : "0.800" + }, + "File::KDBX::IO::HashBlock" : { + "file" : "lib/File/KDBX/IO/HashBlock.pm", + "version" : "0.800" + }, + "File::KDBX::IO::HmacBlock" : { + "file" : "lib/File/KDBX/IO/HmacBlock.pm", + "version" : "0.800" + }, + "File::KDBX::Iterator" : { + "file" : "lib/File/KDBX/Iterator.pm", + "version" : "0.800" + }, + "File::KDBX::KDF" : { + "file" : "lib/File/KDBX/KDF.pm", + "version" : "0.800" + }, + "File::KDBX::KDF::AES" : { + "file" : "lib/File/KDBX/KDF/AES.pm", + "version" : "0.800" + }, + "File::KDBX::KDF::Argon2" : { + "file" : "lib/File/KDBX/KDF/Argon2.pm", + "version" : "0.800" + }, + "File::KDBX::Key" : { + "file" : "lib/File/KDBX/Key.pm", + "version" : "0.800" + }, + "File::KDBX::Key::ChallengeResponse" : { + "file" : "lib/File/KDBX/Key/ChallengeResponse.pm", + "version" : "0.800" + }, + "File::KDBX::Key::Composite" : { + "file" : "lib/File/KDBX/Key/Composite.pm", + "version" : "0.800" + }, + "File::KDBX::Key::File" : { + "file" : "lib/File/KDBX/Key/File.pm", + "version" : "0.800" + }, + "File::KDBX::Key::Password" : { + "file" : "lib/File/KDBX/Key/Password.pm", + "version" : "0.800" + }, + "File::KDBX::Key::YubiKey" : { + "file" : "lib/File/KDBX/Key/YubiKey.pm", + "version" : "0.800" + }, + "File::KDBX::Loader" : { + "file" : "lib/File/KDBX/Loader.pm", + "version" : "0.800" + }, + "File::KDBX::Loader::KDB" : { + "file" : "lib/File/KDBX/Loader/KDB.pm", + "version" : "0.800" + }, + "File::KDBX::Loader::Raw" : { + "file" : "lib/File/KDBX/Loader/Raw.pm", + "version" : "0.800" + }, + "File::KDBX::Loader::V3" : { + "file" : "lib/File/KDBX/Loader/V3.pm", + "version" : "0.800" + }, + "File::KDBX::Loader::V4" : { + "file" : "lib/File/KDBX/Loader/V4.pm", + "version" : "0.800" + }, + "File::KDBX::Loader::XML" : { + "file" : "lib/File/KDBX/Loader/XML.pm", + "version" : "0.800" + }, + "File::KDBX::Object" : { + "file" : "lib/File/KDBX/Object.pm", + "version" : "0.800" + }, + "File::KDBX::Safe" : { + "file" : "lib/File/KDBX/Safe.pm", + "version" : "0.800" + }, + "File::KDBX::Transaction" : { + "file" : "lib/File/KDBX/Transaction.pm", + "version" : "0.800" + }, + "File::KDBX::Util" : { + "file" : "lib/File/KDBX/Util.pm", + "version" : "0.800" + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "web" : "https://github.com/chazmcgarvey/File-KDBX/issues" + }, + "homepage" : "https://github.com/chazmcgarvey/File-KDBX", + "repository" : { + "type" : "git", + "url" : "https://github.com/chazmcgarvey/File-KDBX.git", + "web" : "https://github.com/chazmcgarvey/File-KDBX" + } + }, + "version" : "0.800", + "x_authority" : "cpan:CCM", + "x_generated_by_perl" : "v5.34.1", + "x_serialization_backend" : "Cpanel::JSON::XS version 4.27", + "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later" +} + diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..20edc2c --- /dev/null +++ b/META.yml @@ -0,0 +1,217 @@ +--- +abstract: 'Encrypted database to store secret text and files' +author: + - 'Charles McGarvey ' +build_requires: + ExtUtils::MakeMaker: '0' + File::Spec: '0' + FindBin: '0' + Getopt::Std: '0' + IO::Handle: '0' + IPC::Open3: '0' + Test::Deep: '0' + Test::Fatal: '0' + Test::More: '0' + Test::Warnings: '0' + lib: '0' + perl: '5.006' + utf8: '0' +configure_requires: + ExtUtils::MakeMaker: '0' +dynamic_config: 0 +generated_by: 'Dist::Zilla version 6.024, CPAN::Meta::Converter version 2.150010' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: File-KDBX +no_index: + directory: + - eg + - share + - shares + - t + - xt +optional_features: + compression: + description: 'ability to read and write compressed KDBX files' + requires: + Compress::Raw::Zlib: '0' + IO::Compress::Gzip: '0' + IO::Uncompress::Gunzip: '0' + otp: + description: 'ability to generate one-time passwords from configured database entries' + requires: + Pass::OTP: '0' + xs: + description: 'speed improvements (requires C compiler)' + requires: + File::KDBX::XS: '0' +provides: + File::KDBX: + file: lib/File/KDBX.pm + version: '0.800' + File::KDBX::Cipher: + file: lib/File/KDBX/Cipher.pm + version: '0.800' + File::KDBX::Cipher::CBC: + file: lib/File/KDBX/Cipher/CBC.pm + version: '0.800' + File::KDBX::Cipher::Stream: + file: lib/File/KDBX/Cipher/Stream.pm + version: '0.800' + File::KDBX::Constants: + file: lib/File/KDBX/Constants.pm + version: '0.800' + File::KDBX::Dumper: + file: lib/File/KDBX/Dumper.pm + version: '0.800' + File::KDBX::Dumper::KDB: + file: lib/File/KDBX/Dumper/KDB.pm + version: '0.800' + File::KDBX::Dumper::Raw: + file: lib/File/KDBX/Dumper/Raw.pm + version: '0.800' + File::KDBX::Dumper::V3: + file: lib/File/KDBX/Dumper/V3.pm + version: '0.800' + File::KDBX::Dumper::V4: + file: lib/File/KDBX/Dumper/V4.pm + version: '0.800' + File::KDBX::Dumper::XML: + file: lib/File/KDBX/Dumper/XML.pm + version: '0.800' + File::KDBX::Entry: + file: lib/File/KDBX/Entry.pm + version: '0.800' + File::KDBX::Error: + file: lib/File/KDBX/Error.pm + version: '0.800' + File::KDBX::Group: + file: lib/File/KDBX/Group.pm + version: '0.800' + File::KDBX::IO: + file: lib/File/KDBX/IO.pm + version: '0.800' + File::KDBX::IO::Crypt: + file: lib/File/KDBX/IO/Crypt.pm + version: '0.800' + File::KDBX::IO::HashBlock: + file: lib/File/KDBX/IO/HashBlock.pm + version: '0.800' + File::KDBX::IO::HmacBlock: + file: lib/File/KDBX/IO/HmacBlock.pm + version: '0.800' + File::KDBX::Iterator: + file: lib/File/KDBX/Iterator.pm + version: '0.800' + File::KDBX::KDF: + file: lib/File/KDBX/KDF.pm + version: '0.800' + File::KDBX::KDF::AES: + file: lib/File/KDBX/KDF/AES.pm + version: '0.800' + File::KDBX::KDF::Argon2: + file: lib/File/KDBX/KDF/Argon2.pm + version: '0.800' + File::KDBX::Key: + file: lib/File/KDBX/Key.pm + version: '0.800' + File::KDBX::Key::ChallengeResponse: + file: lib/File/KDBX/Key/ChallengeResponse.pm + version: '0.800' + File::KDBX::Key::Composite: + file: lib/File/KDBX/Key/Composite.pm + version: '0.800' + File::KDBX::Key::File: + file: lib/File/KDBX/Key/File.pm + version: '0.800' + File::KDBX::Key::Password: + file: lib/File/KDBX/Key/Password.pm + version: '0.800' + File::KDBX::Key::YubiKey: + file: lib/File/KDBX/Key/YubiKey.pm + version: '0.800' + File::KDBX::Loader: + file: lib/File/KDBX/Loader.pm + version: '0.800' + File::KDBX::Loader::KDB: + file: lib/File/KDBX/Loader/KDB.pm + version: '0.800' + File::KDBX::Loader::Raw: + file: lib/File/KDBX/Loader/Raw.pm + version: '0.800' + File::KDBX::Loader::V3: + file: lib/File/KDBX/Loader/V3.pm + version: '0.800' + File::KDBX::Loader::V4: + file: lib/File/KDBX/Loader/V4.pm + version: '0.800' + File::KDBX::Loader::XML: + file: lib/File/KDBX/Loader/XML.pm + version: '0.800' + File::KDBX::Object: + file: lib/File/KDBX/Object.pm + version: '0.800' + File::KDBX::Safe: + file: lib/File/KDBX/Safe.pm + version: '0.800' + File::KDBX::Transaction: + file: lib/File/KDBX/Transaction.pm + version: '0.800' + File::KDBX::Util: + file: lib/File/KDBX/Util.pm + version: '0.800' +recommends: + Compress::Raw::Zlib: '0' + File::KDBX::XS: '0' + File::Spec: '0' + IO::Compress::Gzip: '0' + IO::Uncompress::Gunzip: '0' + Pass::OTP: '0' +requires: + Carp: '0' + Crypt::Argon2: '0' + Crypt::Cipher: '0' + Crypt::Digest: '0' + Crypt::Mac::HMAC: '0' + Crypt::Misc: '0.029' + Crypt::Mode::CBC: '0' + Crypt::PRNG: '0' + Data::Dumper: '0' + Devel::GlobalDestruction: '0' + Encode: '0' + Exporter: '0' + File::Temp: '0' + Hash::Util::FieldHash: '0' + IO::Handle: '0' + IPC::Cmd: '0.52' + Iterator::Simple: '0' + Iterator::Simple::Iterator: '0' + List::Util: '1.33' + Module::Load: '0' + Module::Loaded: '0' + POSIX: '0' + Ref::Util: '0' + Scalar::Util: '0' + Scope::Guard: '0' + Storable: '0' + Symbol: '0' + Text::ParseWords: '0' + Time::Piece: '0' + XML::LibXML: '0' + XML::LibXML::Reader: '0' + boolean: '0' + namespace::clean: '0' + overload: '0' + strict: '0' + warnings: '0' +resources: + bugtracker: https://github.com/chazmcgarvey/File-KDBX/issues + homepage: https://github.com/chazmcgarvey/File-KDBX + repository: https://github.com/chazmcgarvey/File-KDBX.git +version: '0.800' +x_authority: cpan:CCM +x_generated_by_perl: v5.34.1 +x_serialization_backend: 'YAML::Tiny version 1.73' +x_spdx_expression: 'Artistic-1.0-Perl OR GPL-1.0-or-later' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..83053fc --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,138 @@ +# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.024. +use strict; +use warnings; + +use 5.006; + +use ExtUtils::MakeMaker; + +my %WriteMakefileArgs = ( + "ABSTRACT" => "Encrypted database to store secret text and files", + "AUTHOR" => "Charles McGarvey ", + "CONFIGURE_REQUIRES" => { + "ExtUtils::MakeMaker" => 0 + }, + "DISTNAME" => "File-KDBX", + "LICENSE" => "perl", + "MIN_PERL_VERSION" => "5.006", + "NAME" => "File::KDBX", + "PREREQ_PM" => { + "Carp" => 0, + "Crypt::Argon2" => 0, + "Crypt::Cipher" => 0, + "Crypt::Digest" => 0, + "Crypt::Mac::HMAC" => 0, + "Crypt::Misc" => "0.029", + "Crypt::Mode::CBC" => 0, + "Crypt::PRNG" => 0, + "Data::Dumper" => 0, + "Devel::GlobalDestruction" => 0, + "Encode" => 0, + "Exporter" => 0, + "File::Temp" => 0, + "Hash::Util::FieldHash" => 0, + "IO::Handle" => 0, + "IPC::Cmd" => "0.52", + "Iterator::Simple" => 0, + "Iterator::Simple::Iterator" => 0, + "List::Util" => "1.33", + "Module::Load" => 0, + "Module::Loaded" => 0, + "POSIX" => 0, + "Ref::Util" => 0, + "Scalar::Util" => 0, + "Scope::Guard" => 0, + "Storable" => 0, + "Symbol" => 0, + "Text::ParseWords" => 0, + "Time::Piece" => 0, + "XML::LibXML" => 0, + "XML::LibXML::Reader" => 0, + "boolean" => 0, + "namespace::clean" => 0, + "overload" => 0, + "strict" => 0, + "warnings" => 0 + }, + "TEST_REQUIRES" => { + "ExtUtils::MakeMaker" => 0, + "File::Spec" => 0, + "FindBin" => 0, + "Getopt::Std" => 0, + "IO::Handle" => 0, + "IPC::Open3" => 0, + "Test::Deep" => 0, + "Test::Fatal" => 0, + "Test::More" => 0, + "Test::Warnings" => 0, + "lib" => 0, + "utf8" => 0 + }, + "VERSION" => "0.800", + "test" => { + "TESTS" => "t/*.t" + } +); + + +my %FallbackPrereqs = ( + "Carp" => 0, + "Crypt::Argon2" => 0, + "Crypt::Cipher" => 0, + "Crypt::Digest" => 0, + "Crypt::Mac::HMAC" => 0, + "Crypt::Misc" => "0.029", + "Crypt::Mode::CBC" => 0, + "Crypt::PRNG" => 0, + "Data::Dumper" => 0, + "Devel::GlobalDestruction" => 0, + "Encode" => 0, + "Exporter" => 0, + "ExtUtils::MakeMaker" => 0, + "File::Spec" => 0, + "File::Temp" => 0, + "FindBin" => 0, + "Getopt::Std" => 0, + "Hash::Util::FieldHash" => 0, + "IO::Handle" => 0, + "IPC::Cmd" => "0.52", + "IPC::Open3" => 0, + "Iterator::Simple" => 0, + "Iterator::Simple::Iterator" => 0, + "List::Util" => "1.33", + "Module::Load" => 0, + "Module::Loaded" => 0, + "POSIX" => 0, + "Ref::Util" => 0, + "Scalar::Util" => 0, + "Scope::Guard" => 0, + "Storable" => 0, + "Symbol" => 0, + "Test::Deep" => 0, + "Test::Fatal" => 0, + "Test::More" => 0, + "Test::Warnings" => 0, + "Text::ParseWords" => 0, + "Time::Piece" => 0, + "XML::LibXML" => 0, + "XML::LibXML::Reader" => 0, + "boolean" => 0, + "lib" => 0, + "namespace::clean" => 0, + "overload" => 0, + "strict" => 0, + "utf8" => 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); diff --git a/README b/README new file mode 100644 index 0000000..800d034 --- /dev/null +++ b/README @@ -0,0 +1,1605 @@ +NAME + + File::KDBX - Encrypted database to store secret text and files + +VERSION + + version 0.800 + +SYNOPSIS + + use File::KDBX; + + my $kdbx = File::KDBX->new; + + my $group = $kdbx->add_group( + name => 'Passwords', + ); + + my $entry = $group->add_entry( + title => 'My Bank', + password => 's3cr3t', + ); + + $kdbx->dump_file('passwords.kdbx', 'M@st3rP@ssw0rd!'); + + $kdbx = File::KDBX->load_file('passwords.kdbx', 'M@st3rP@ssw0rd!'); + + $kdbx->entries->each(sub { + my ($entry) = @_; + say 'Entry: ', $entry->title; + }); + + See "RECIPES" for more examples. + +DESCRIPTION + + File::KDBX provides everything you need to work with a KDBX database. A + KDBX database is a hierarchical object database which is commonly used + to store secret information securely. It was developed for the KeePass + password safe. See "Introduction to KDBX" for more information about + KDBX. + + This module lets you query entries, create new entries, delete entries + and modify entries. The distribution also includes various parsers and + generators for serializing and persisting databases. + + This design of this software was influenced by the KeePassXC + implementation of KeePass + as well as the File::KeePass module. File::KeePass is an alternative + module that works well in most cases but has a small backlog of bugs + and security issues and also does not work with newer KDBX version 4 + files. If you're coming here from the File::KeePass world, you might be + interested in File::KeePass::KDBX that is a drop-in replacement for + File::KeePass that uses File::KDBX for storage. + + This software is a pre-1.0 release. The interface should be considered + pretty stable, but there might be minor changes up until a 1.0 release. + Breaking changes will be noted in the Changes file. + + Features + + This implementation of KDBX supports a lot of features: + + * ☑ Read and write KDBX version 3 - version 4.1 + + * ☑ Read and write KDB files (requires File::KeePass) + + * ☑ Unicode character strings + + * ☑ "Simple Expression" Searching + + * ☑ Placeholders and field references + + * ☑ One-time passwords + + * ☑ Very secure + + * ☑ "Memory Protection" + + * ☑ Challenge-response key components, like YubiKey + + * ☑ Variety of key file types: binary, hexed, hashed, XML v1 and v2 + + * ☑ Pluggable registration of different kinds of ciphers and key + derivation functions + + * ☑ Built-in database maintenance functions + + * ☑ Pretty fast, with XS optimizations available + + * ☒ Database synchronization / merging (not yet) + + Introduction to KDBX + + A KDBX database consists of a tree of groups and entries, with a single + root group. Entries can contain zero or more key-value pairs of strings + and zero or more binaries (i.e. octet strings). Groups, entries, + strings and binaries: that's the KDBX vernacular. A small amount of + metadata (timestamps, etc.) is associated with each entry, group and + the database as a whole. + + You can think of a KDBX database kind of like a file system, where + groups are directories, entries are files, and strings and binaries + make up a file's contents. + + Databases are typically persisted as a encrypted, compressed files. + They are usually accessed directly (i.e. not over a network). The + primary focus of this type of database is data security. It is ideal + for storing relatively small amounts of data (strings and binaries) + that must remain secret except to such individuals as have the correct + master key. Even if the database file were to be "leaked" to the public + Internet, it should be virtually impossible to crack with a strong key. + The KDBX format is most often used by password managers to store + passwords so that users can know a single strong password and not have + to reuse passwords across different websites. See "SECURITY" for an + overview of security considerations. + +ATTRIBUTES + + sig1 + + sig2 + + version + + headers + + inner_headers + + meta + + binaries + + deleted_objects + + Hash of UUIDs for objects that have been deleted. This includes groups, + entries and even custom icons. + + raw + + Bytes contained within the encrypted layer of a KDBX file. This is only + set when using File::KDBX::Loader::Raw. + + comment + + A text string associated with the database. Often unset. + + cipher_id + + The UUID of a cipher used to encrypt the database when stored as a + file. + + See "File::KDBX::Cipher". + + compression_flags + + Configuration for whether or not and how the database gets compressed. + See ":compression" in File::KDBX::Constants. + + master_seed + + The master seed is a string of 32 random bytes that is used as salt in + hashing the master key when loading and saving the database. If a + challenge-response key is used in the master key, the master seed is + also the challenge. + + The master seed should be changed each time the database is saved to + file. + + transform_seed + + The transform seed is a string of 32 random bytes that is used in the + key derivation function, either as the salt or the key (depending on + the algorithm). + + The transform seed should be changed each time the database is saved to + file. + + transform_rounds + + The number of rounds or iterations used in the key derivation function. + Increasing this number makes loading and saving the database slower by + design in order to make dictionary and brute force attacks more costly. + + encryption_iv + + The initialization vector used by the cipher. + + The encryption IV should be changed each time the database is saved to + file. + + inner_random_stream_key + + The encryption key (possibly including the IV, depending on the cipher) + used to encrypt the protected strings within the database. + + stream_start_bytes + + A string of 32 random bytes written in the header and encrypted in the + body. If the bytes do not match when loading a file then the wrong + master key was used or the file is corrupt. Only KDBX 2 and KDBX 3 + files use this. KDBX 4 files use an improved HMAC method to verify the + master key and data integrity of the header and entire file body. + + inner_random_stream_id + + A number indicating the cipher algorithm used to encrypt the protected + strings within the database, usually Salsa20 or ChaCha20. See + ":random_stream" in File::KDBX::Constants. + + kdf_parameters + + A hash/dict of key-value pairs used to configure the key derivation + function. This is the KDBX4+ way to configure the KDF, superceding + "transform_seed" and "transform_rounds". + + generator + + The name of the software used to generate the KDBX file. + + header_hash + + The header hash used to verify that the file header is not corrupt. + (KDBX 2 - KDBX 3.1, removed KDBX 4.0) + + database_name + + Name of the database. + + database_name_changed + + Timestamp indicating when the database name was last changed. + + database_description + + Description of the database + + database_description_changed + + Timestamp indicating when the database description was last changed. + + default_username + + When a new entry is created, the UserName string will be populated with + this value. + + default_username_changed + + Timestamp indicating when the default username was last changed. + + maintenance_history_days + + TODO... not really sure what this is. 😀 + + color + + A color associated with the database (in the form #ffffff where "f" is + a hexidecimal digit). Some agents use this to help users visually + distinguish between different databases. + + master_key_changed + + Timestamp indicating when the master key was last changed. + + master_key_change_rec + + Number of days until the agent should prompt to recommend changing the + master key. + + master_key_change_force + + Number of days until the agent should prompt to force changing the + master key. + + Note: This is purely advisory. It is up to the individual agent + software to actually enforce it. File::KDBX does NOT enforce it. + + custom_icons + + Array of custom icons that can be associated with groups and entries. + + This list can be managed with the methods "add_custom_icon" and + "remove_custom_icon". + + recycle_bin_enabled + + Boolean indicating whether removed groups and entries should go to a + recycle bin or be immediately deleted. + + recycle_bin_uuid + + The UUID of a group used to store thrown-away groups and entries. + + recycle_bin_changed + + Timestamp indicating when the recycle bin was last changed. + + entry_templates_group + + The UUID of a group containing template entries used when creating new + entries. + + entry_templates_group_changed + + Timestamp indicating when the entry templates group was last changed. + + last_selected_group + + The UUID of the previously-selected group. + + last_top_visible_group + + The UUID of the group visible at the top of the list. + + history_max_items + + The maximum number of historical entries allowed to be saved for each + entry. + + history_max_size + + The maximum total size (in bytes) that each individual entry's history + is allowed to grow. + + settings_changed + + Timestamp indicating when the database settings were last updated. + + protect_title + + Alias of the "memory_protection" setting for the Title string. + + protect_username + + Alias of the "memory_protection" setting for the UserName string. + + protect_password + + Alias of the "memory_protection" setting for the Password string. + + protect_url + + Alias of the "memory_protection" setting for the URL string. + + protect_notes + + Alias of the "memory_protection" setting for the Notes string. + +METHODS + + new + + $kdbx = File::KDBX->new(%attributes); + $kdbx = File::KDBX->new($kdbx); # copy constructor + + Construct a new File::KDBX. + + init + + $kdbx = $kdbx->init(%attributes); + + Initialize a File::KDBX with a set of attributes. Returns itself to + allow method chaining. + + This is called by "new". + + reset + + $kdbx = $kdbx->reset; + + Set a File::KDBX to an empty state, ready to load a KDBX file or build + a new one. Returns itself to allow method chaining. + + clone + + $kdbx_copy = $kdbx->clone; + $kdbx_copy = File::KDBX->new($kdbx); + + Clone a File::KDBX. The clone will be an exact copy and completely + independent of the original. + + load + + load_string + + load_file + + load_handle + + $kdbx = KDBX::File->load(\$string, $key); + $kdbx = KDBX::File->load(*IO, $key); + $kdbx = KDBX::File->load($filepath, $key); + $kdbx->load(...); # also instance method + + $kdbx = File::KDBX->load_string($string, $key); + $kdbx = File::KDBX->load_string(\$string, $key); + $kdbx->load_string(...); # also instance method + + $kdbx = File::KDBX->load_file($filepath, $key); + $kdbx->load_file(...); # also instance method + + $kdbx = File::KDBX->load_handle($fh, $key); + $kdbx = File::KDBX->load_handle(*IO, $key); + $kdbx->load_handle(...); # also instance method + + Load a KDBX file from a string buffer, IO handle or file from a + filesystem. + + File::KDBX::Loader does the heavy lifting. + + dump + + dump_string + + dump_file + + dump_handle + + $kdbx->dump(\$string, $key); + $kdbx->dump(*IO, $key); + $kdbx->dump($filepath, $key); + + $kdbx->dump_string(\$string, $key); + \$string = $kdbx->dump_string($key); + + $kdbx->dump_file($filepath, $key); + + $kdbx->dump_handle($fh, $key); + $kdbx->dump_handle(*IO, $key); + + Dump a KDBX file to a string buffer, IO handle or file in a filesystem. + + File::KDBX::Dumper does the heavy lifting. + + user_agent_string + + $string = $kdbx->user_agent_string; + + Get a text string identifying the database client software. + + memory_protection + + \%settings = $kdbx->memory_protection + $kdbx->memory_protection(\%settings); + + $bool = $kdbx->memory_protection($string_key); + $kdbx->memory_protection($string_key => $bool); + + Get or set memory protection settings. This globally (for the whole + database) configures whether and which of the standard strings should + be memory-protected. The default setting is to memory-protect only + Password strings. + + Memory protection can be toggled individually for each entry string, + and individual settings take precedence over these global settings. + + minimum_version + + $version = $kdbx->minimum_version; + + Determine the minimum file version required to save a database + losslessly. Using certain databases features might increase this value. + For example, setting the KDF to Argon2 will increase the minimum + version to at least KDBX_VERSION_4_0 (i.e. 0x00040000) because Argon2 + was introduced with KDBX4. + + This method never returns less than KDBX_VERSION_3_1 (i.e. 0x00030001). + That file version is so ubiquitious and well-supported, there are + seldom reasons to dump in a lesser format nowadays. + + WARNING: If you dump a database with a minimum version higher than the + current "version", the dumper will typically issue a warning and + automatically upgrade the database. This seems like the safest behavior + in order to avoid data loss, but lower versions have the benefit of + being compatible with more software. It is possible to prevent + auto-upgrades by explicitly telling the dumper which version to use, + but you do run the risk of data loss. A database will never be + automatically downgraded. + + root + + $group = $kdbx->root; + $kdbx->root($group); + + Get or set a database's root group. You don't necessarily need to + explicitly create or set a root group because it autovivifies when + adding entries and groups to the database. + + Every database has only a single root group at a time. Some old KDB + files might have multiple root groups. When reading such files, a + single implicit root group is created to contain the actual root + groups. When writing to such a format, if the root group looks like it + was implicitly created then it won't be written and the resulting file + might have multiple root groups. This allows working with older files + without changing their written internal structure while still adhering + to modern semantics while the database is opened. + + The root group of a KDBX database contains all of the database's + entries and other groups. If you replace the root group, you are + essentially replacing the entire database contents with something else. + + trace_lineage + + \@lineage = $kdbx->trace_lineage($group); + \@lineage = $kdbx->trace_lineage($group, $base_group); + \@lineage = $kdbx->trace_lineage($entry); + \@lineage = $kdbx->trace_lineage($entry, $base_group); + + Get the direct line of ancestors from $base_group (default: the root + group) to a group or entry. The lineage includes the base group but not + the target group or entry. Returns undef if the target is not in the + database structure. + + recycle_bin + + $group = $kdbx->recycle_bin; + $kdbx->recycle_bin($group); + + Get or set the recycle bin group. Returns undef if there is no recycle + bin and "recycle_bin_enabled" is false, otherwise the current recycle + bin or an autovivified recycle bin group is returned. + + entry_templates + + $group = $kdbx->entry_templates; + $kdbx->entry_templates($group); + + Get or set the entry templates group. May return undef if unset. + + last_selected + + $group = $kdbx->last_selected; + $kdbx->last_selected($group); + + Get or set the last selected group. May return undef if unset. + + last_top_visible + + $group = $kdbx->last_top_visible; + $kdbx->last_top_visible($group); + + Get or set the last top visible group. May return undef if unset. + + add_group + + $kdbx->add_group($group); + $kdbx->add_group(%group_attributes, %options); + + Add a group to a database. This is equivalent to identifying a parent + group and calling "add_group" in File::KDBX::Group on the parent group, + forwarding the arguments. Available options: + + * group (aka parent) - Group object or group UUID to add the group to + (default: root group) + + groups + + \&iterator = $kdbx->groups(%options); + \&iterator = $kdbx->groups($base_group, %options); + + Get an File::KDBX::Iterator over groups within a database. Options: + + * base - Only include groups within a base group (same as + $base_group) (default: "root") + + * inclusive - Include the base group in the results (default: true) + + * algorithm - Search algorithm, one of ids, bfs or dfs (default: ids) + + add_entry + + $kdbx->add_entry($entry, %options); + $kdbx->add_entry(%entry_attributes, %options); + + Add a entry to a database. This is equivalent to identifying a parent + group and calling "add_entry" in File::KDBX::Group on the parent group, + forwarding the arguments. Available options: + + * group (aka parent) - Group object or group UUID to add the entry to + (default: root group) + + entries + + \&iterator = $kdbx->entries(%options); + \&iterator = $kdbx->entries($base_group, %options); + + Get an File::KDBX::Iterator over entries within a database. Supports + the same options as "groups", plus some new ones: + + * auto_type - Only include entries with auto-type enabled (default: + false, include all) + + * searching - Only include entries within groups with searching + enabled (default: false, include all) + + * history - Also include historical entries (default: false, include + only current entries) + + objects + + \&iterator = $kdbx->objects(%options); + \&iterator = $kdbx->objects($base_group, %options); + + Get an File::KDBX::Iterator over objects within a database. Groups and + entries are considered objects, so this is essentially a combination of + "groups" and "entries". This won't often be useful, but it can be + convenient for maintenance tasks. This method takes the same options as + "groups" and "entries". + + custom_icon + + \%icon = $kdbx->custom_icon($uuid); + $kdbx->custom_icon($uuid => \%icon); + $kdbx->custom_icon(%icon); + $kdbx->custom_icon(uuid => $value, %icon); + + Get or set custom icons. + + custom_icon_data + + $image_data = $kdbx->custom_icon_data($uuid); + + Get a custom icon image data. + + add_custom_icon + + $uuid = $kdbx->add_custom_icon($image_data, %attributes); + $uuid = $kdbx->add_custom_icon(%attributes); + + Add a custom icon and get its UUID. If not provided, a random UUID will + be generated. Possible attributes: + + * uuid - Icon UUID (default: autogenerated) + + * data - Image data (same as $image_data) + + * name - Name of the icon (text, KDBX4.1+) + + * last_modification_time - Just what it says (datetime, KDBX4.1+) + + remove_custom_icon + + $kdbx->remove_custom_icon($uuid); + + Remove a custom icon. + + custom_data + + \%all_data = $kdbx->custom_data; + $kdbx->custom_data(\%all_data); + + \%data = $kdbx->custom_data($key); + $kdbx->custom_data($key => \%data); + $kdbx->custom_data(%data); + $kdbx->custom_data(key => $value, %data); + + Get and set custom data. Custom data is metadata associated with a + database. + + Each data item can have a few attributes associated with it. + + * key - A unique text string identifier used to look up the data item + (required) + + * value - A text string value (required) + + * last_modification_time (optional, KDBX4.1+) + + custom_data_value + + $value = $kdbx->custom_data_value($key); + + Exactly the same as "custom_data" except returns just the custom data's + value rather than a structure of attributes. This is a shortcut for: + + my $data = $kdbx->custom_data($key); + my $value = defined $data ? $data->{value} : undef; + + public_custom_data + + \%all_data = $kdbx->public_custom_data; + $kdbx->public_custom_data(\%all_data); + + $value = $kdbx->public_custom_data($key); + $kdbx->public_custom_data($key => $value); + + Get and set public custom data. Public custom data is similar to custom + data but different in some important ways. Public custom data: + + * can store strings, booleans and up to 64-bit integer values (custom + data can only store text values) + + * is NOT encrypted within a KDBX file (hence the "public" part of the + name) + + * is a plain hash/dict of key-value pairs with no other associated + fields (like modification times) + + add_deleted_object + + $kdbx->add_deleted_object($uuid); + + Add a UUID to the deleted objects list. This list is used to support + automatic database merging. + + You typically do not need to call this yourself because the list will + be populated automatically as objects are removed. + + remove_deleted_object + + $kdbx->remove_deleted_object($uuid); + + Remove a UUID from the deleted objects list. This list is used to + support automatic database merging. + + You typically do not need to call this yourself because the list will + be maintained automatically as objects are added. + + clear_deleted_objects + + Remove all UUIDs from the deleted objects list. This list is used to + support automatic database merging, but if you don't need merging then + you can clear deleted objects to reduce the database file size. + + resolve_reference + + $string = $kdbx->resolve_reference($reference); + $string = $kdbx->resolve_reference($wanted, $search_in, $expression); + + Resolve a field reference + . A field reference is a + kind of string placeholder. You can use a field reference to refer + directly to a standard field within an entry. Field references are + resolved automatically while expanding entry strings (i.e. replacing + placeholders), but you can use this method to resolve on-the-fly + references that aren't part of any actual string in the database. + + If the reference does not resolve to any field, undef is returned. If + the reference resolves to multiple fields, only the first one is + returned (in the same order as iterated by "entries"). To avoid + ambiguity, you can refer to a specific entry by its UUID. + + The syntax of a reference is: {REF:@:}. + Text is a "Simple Expression". WantedField and SearchIn are both single + character codes representing a field: + + * T - Title + + * U - UserName + + * P - Password + + * A - URL + + * N - Notes + + * I - UUID + + * O - Other custom strings + + Since O does not represent any specific field, it cannot be used as the + WantedField. + + Examples: + + To get the value of the UserName string of the first entry with "My + Bank" in the title: + + my $username = $kdbx->resolve_reference('{REF:U@T:"My Bank"}'); + # OR the {REF:...} wrapper is optional + my $username = $kdbx->resolve_reference('U@T:"My Bank"'); + # OR separate the arguments + my $username = $kdbx->resolve_reference(U => T => '"My Bank"'); + + Note how the text is a "Simple Expression", so search terms with spaces + must be surrounded in double quotes. + + To get the Password string of a specific entry (identified by its + UUID): + + my $password = $kdbx->resolve_reference('{REF:P@I:46C9B1FFBD4ABC4BBB260C6190BAD20C}'); + + lock + + $kdbx->lock; + + Encrypt all protected binaries strings in a database. The encrypted + strings are stored in a File::KDBX::Safe associated with the database + and the actual strings will be replaced with undef to indicate their + protected state. Returns itself to allow method chaining. + + You can call code on an already-locked database to memory-protect any + unprotected strings and binaries added after the last time the database + was locked. + + unlock + + $kdbx->unlock; + + Decrypt all protected strings in a database, replacing undef + placeholders with unprotected values. Returns itself to allow method + chaining. + + unlock_scoped + + $guard = $kdbx->unlock_scoped; + + Unlock a database temporarily, relocking when the guard is released + (typically at the end of a scope). Returns undef if the database is + already unlocked. + + See "lock" and "unlock". + + peek + + $string = $kdbx->peek(\%string); + $string = $kdbx->peek(\%binary); + + Peek at the value of a protected string or binary without unlocking the + whole database. The argument can be a string or binary hashref as + returned by "string" in File::KDBX::Entry or "binary" in + File::KDBX::Entry. + + is_locked + + $bool = $kdbx->is_locked; + + Get whether or not a database's strings are memory-protected. If this + is true, then some or all of the protected strings within the database + will be unavailable (literally have undef values) until "unlock" is + called. + + remove_empty_groups + + $kdbx->remove_empty_groups; + + Remove groups with no subgroups and no entries. + + remove_unused_icons + + $kdbx->remove_unused_icons; + + Remove icons that are not associated with any entry or group in the + database. + + remove_duplicate_icons + + $kdbx->remove_duplicate_icons; + + Remove duplicate icons as determined by hashing the icon data. + + prune_history + + $kdbx->prune_history(%options); + + Remove just as many older historical entries as necessary to get under + certain limits. + + * max_items - Maximum number of historical entries to keep (default: + value of "history_max_items", no limit: -1) + + * max_size - Maximum total size (in bytes) of historical entries to + keep (default: value of "history_max_size", no limit: -1) + + * max_age - Maximum age (in days) of historical entries to keep + (default: 365, no limit: -1) + + randomize_seeds + + $kdbx->randomize_seeds; + + Set various keys, seeds and IVs to random values. These values are used + by the cryptographic functions that secure the database when dumped. + The attributes that will be randomized are: + + * "encryption_iv" + + * "inner_random_stream_key" + + * "master_seed" + + * "stream_start_bytes" + + * "transform_seed" + + Randomizing these values has no effect on a loaded database. These are + only used when a database is dumped. You normally do not need to call + this method explicitly because the dumper does it explicitly by + default. + + key + + $key = $kdbx->key; + $key = $kdbx->key($key); + $key = $kdbx->key($primitive); + + Get or set a File::KDBX::Key. This is the master key (e.g. a password + or a key file that can decrypt a database). See "new" in + File::KDBX::Key for an explanation of what the primitive can be. + + You generally don't need to call this directly because you can provide + the key directly to the loader or dumper when loading or dumping a KDBX + file. + + composite_key + + $key = $kdbx->composite_key($key); + $key = $kdbx->composite_key($primitive); + + Construct a File::KDBX::Key::Composite from a primitive. See "new" in + File::KDBX::Key for an explanation of what the primitive can be. If the + primitive does not represent a composite key, it will be wrapped. + + You generally don't need to call this directly. The parser and writer + use it to transform a master key into a raw encryption key. + + kdf + + $kdf = $kdbx->kdf(%options); + $kdf = $kdbx->kdf(\%parameters, %options); + + Get a File::KDBX::KDF (key derivation function). + + Options: + + * params - KDF parameters, same as \%parameters (default: value of + "kdf_parameters") + + cipher + + $cipher = $kdbx->cipher(key => $key); + $cipher = $kdbx->cipher(key => $key, iv => $iv, uuid => $uuid); + + Get a File::KDBX::Cipher capable of encrypting and decrypting the body + of a database file. + + A key is required. This should be a raw encryption key made up of a + fixed number of octets (depending on the cipher), not a File::KDBX::Key + or primitive. + + If not passed, the UUID comes from $kdbx->headers->{cipher_id} and the + encryption IV comes from $kdbx->headers->{encryption_iv}. + + You generally don't need to call this directly. The parser and writer + use it to decrypt and encrypt KDBX files. + + random_stream + + $cipher = $kdbx->random_stream; + $cipher = $kdbx->random_stream(id => $stream_id, key => $key); + + Get a File::KDBX::Cipher::Stream for decrypting and encrypting + protected values. + + If not passed, the ID and encryption key comes from + $kdbx->headers->{inner_random_stream_id} and + $kdbx->headers->{inner_random_stream_key} (respectively) for KDBX3 + files and from $kdbx->inner_headers->{inner_random_stream_key} and + $kdbx->inner_headers->{inner_random_stream_id} (respectively) for KDBX4 + files. + + You generally don't need to call this directly. The parser and writer + use it to scramble protected strings. + +RECIPES + + Create a new database + + my $kdbx = File::KDBX->new; + + my $group = $kdbx->add_group(name => 'Passwords); + my $entry = $group->add_entry( + title => 'WayneCorp', + username => 'bwayne', + password => 'iambatman', + url => 'https://example.com/login' + ); + $entry->add_auto_type_window_association('WayneCorp - Mozilla Firefox', '{PASSWORD}{ENTER}'); + + $kdbx->dump_file('mypasswords.kdbx', 'master password CHANGEME'); + + Read an existing database + + my $kdbx = File::KDBX->load_file('mypasswords.kdbx', 'master password CHANGEME'); + $kdbx->unlock; # cause $entry->password below to be defined + + $kdbx->entries->each(sub { + my ($entry) = @_; + say 'Found password for: ', $entry->title; + say ' Username: ', $entry->username; + say ' Password: ', $entry->password; + }); + + Search for entries + + my @entries = $kdbx->entries(searching => 1) + ->grep(title => 'WayneCorp') + ->each; # return all matches + + The searching option limits results to only entries within groups with + searching enabled. Other options are also available. See "entries". + + See "QUERY" for many more query examples. + + Search for entries by auto-type window association + + my $window_title = 'WayneCorp - Mozilla Firefox'; + + my $entries = $kdbx->entries(auto_type => 1) + ->filter(sub { + my ($ata) = grep { $_->{window} =~ /\Q$window_title\E/i } @{$_->auto_type_associations}; + return [$_, $ata->{keystroke_sequence}] if $ata; + }) + ->each(sub { + my ($entry, $keys) = @$_; + say 'Entry title: ', $entry->title, ', key sequence: ', $keys; + }); + + Example output: + + Entry title: WayneCorp, key sequence: {PASSWORD}{ENTER} + + Remove entries from a database + + $kdbx->entries + ->grep(notes => {'=~' => qr/too old/i}) + ->each(sub { $_->recycle }); + + Recycle all entries with the string "too old" appearing in the Notes + string. + + Remove empty groups + + $kdbx->groups(algorithm => 'dfs') + ->where(-true => 'is_empty') + ->each('remove'); + + With the search/iteration algorithm set to "dfs", groups will be + ordered deepest first and the root group will be last. This allows + removing groups that only contain empty groups. + + This can also be done with one call to "remove_empty_groups". + +SECURITY + + One of the biggest threats to your database security is how easily the + encryption key can be brute-forced. Strong brute-force protection + depends on: + + * Using unguessable passwords, passphrases and key files. + + * Using a brute-force resistent key derivation function. + + The first factor is up to you. This module does not enforce strong + master keys. It is up to you to pick or generate strong keys. + + The KDBX format allows for the key derivation function to be tuned. The + idea is that you want each single brute-foce attempt to be expensive + (in terms of time, CPU usage or memory usage), so that making a lot of + attempts (which would be required if you have a strong master key) gets + really expensive. + + How expensive you want to make each attempt is up to you and can depend + on the application. + + This and other KDBX-related security issues are covered here more in + depth: https://keepass.info/help/base/security.html + + Here are other security risks you should be thinking about: + + Cryptography + + This distribution uses the excellent CryptX and Crypt::Argon2 packages + to handle all crypto-related functions. As such, a lot of the security + depends on the quality of these dependencies. Fortunately these modules + are maintained and appear to have good track records. + + The KDBX format has evolved over time to incorporate improved security + practices and cryptographic functions. This package uses the following + functions for authentication, hashing, encryption and random number + generation: + + * AES-128 (legacy) + + * AES-256 + + * Argon2d & Argon2id + + * CBC block mode + + * HMAC-SHA256 + + * SHA256 + + * SHA512 + + * Salsa20 & ChaCha20 + + * Twofish + + At the time of this writing, I am not aware of any successful attacks + against any of these functions. These are among the most-analyzed and + widely-adopted crypto functions available. + + The KDBX format allows the body cipher and key derivation function to + be configured. If a flaw is discovered in one of these functions, you + can hopefully just switch to a better function without needing to + update this software. A later software release may phase out the use of + any functions which are no longer secure. + + Memory Protection + + It is not a good idea to keep secret information unencrypted in system + memory for longer than is needed. The address space of your program can + generally be read by a user with elevated privileges on the system. If + your system is memory-constrained or goes into a hibernation mode, the + contents of your address space could be written to a disk where it + might be persisted for long time. + + There might be system-level things you can do to reduce your risk, like + using swap encryption and limiting system access to your program's + address space while your program is running. + + File::KDBX helps minimize (but not eliminate) risk by keeping secrets + encrypted in memory until accessed and zeroing out memory that holds + secrets after they're no longer needed, but it's not a silver bullet. + + For one thing, the encryption key is stored in the same address space. + If core is dumped, the encryption key is available to be found out. But + at least there is the chance that the encryption key and the encrypted + secrets won't both be paged out together while memory-constrained. + + Another problem is that some perls (somewhat notoriously) copy around + memory behind the scenes willy nilly, and it's difficult know when perl + makes a copy of a secret in order to be able to zero it out later. It + might be impossible. The good news is that perls with SvPV + copy-on-write (enabled by default beginning with perl 5.20) are much + better in this regard. With COW, it's mostly possible to know what + operations will cause perl to copy the memory of a scalar string, and + the number of copies will be significantly reduced. There is a unit + test named t/memory-protection.t in this distribution that can be run + on POSIX systems to determine how well File::KDBX memory protection is + working. + + Memory protection also depends on how your application handles secrets. + If your app code is handling scalar strings with secret information, + it's up to you to make sure its memory is zeroed out when no longer + needed. "erase" in File::KDBX::Util et al. provide some tools to help + accomplish this. Or if you're not too concerned about the risks memory + protection is meant to mitigate, then maybe don't worry about it. The + security policy of File::KDBX is to try hard to keep secrets protected + while in memory so that your app might claim a high level of security, + in case you care about that. + + There are some memory protection strategies that File::KDBX does NOT + use today but could in the future: + + Many systems allow programs to mark unswappable pages. Secret + information should ideally be stored in such pages. You could + potentially use mlockall(2) (or equivalent for your system) in your own + application to prevent the entire address space from being swapped. + + Some systems provide special syscalls for storing secrets in memory + while keeping the encryption key outside of the program's address + space, like CryptProtectMemory for Windows. This could be a good + option, though unfortunately not portable. + +QUERY + + To find things in a KDBX database, you should use a filtered iterator. + If you have an iterator, such as returned by "entries", "groups" or + even "objects" you can filter it using "where" in File::KDBX::Iterator. + + my $filtered_entries = $kdbx->entries->where($query); + + A $query is just a subroutine that you can either write yourself or + have generated for you from either a "Simple Expression" or + "Declarative Syntax". It's easier to have your query generated, so I'll + cover that first. + + Simple Expression + + A simple expression is mostly compatible with the KeePass 2 + implementation described here + . + + An expression is a string with one or more space-separated terms. Terms + with spaces can be enclosed in double quotes. Terms are negated if they + are prefixed with a minus sign. A record must match every term on at + least one of the given fields. + + So a simple expression is something like what you might type into a + search engine. You can generate a simple expression query using + "simple_expression_query" in File::KDBX::Util or by passing the simple + expression as a scalar reference to where. + + To search for all entries in a database with the word "canyon" + appearing anywhere in the title: + + my $entries = $kdbx->entries->where(\'canyon', qw[title]); + + Notice the first argument is a scalarref. This disambiguates a simple + expression from other types of queries covered below. + + As mentioned, a simple expression can have multiple terms. This simple + expression query matches any entry that has the words "red" and + "canyon" anywhere in the title: + + my $entries = $kdbx->entries->where(\'red canyon', qw[title]); + + Each term in the simple expression must be found for an entry to match. + + To search for entries with "red" in the title but not "canyon", just + prepend "canyon" with a minus sign: + + my $entries = $kdbx->entries->where(\'red -canyon', qw[title]); + + To search over multiple fields simultaneously, just list them all. To + search for entries with "grocery" (but not "Foodland") in the title or + notes: + + my $entries = $kdbx->entries->where(\'grocery -Foodland', qw[title notes]); + + The default operator is a case-insensitive regexp match, which is fine + for searching text loosely. You can use just about any binary + comparison operator that perl supports. To specify an operator, list it + after the simple expression. For example, to search for any entry that + has been used at least five times: + + my $entries = $kdbx->entries->where(\5, '>=', qw[usage_count]); + + It helps to read it right-to-left, like "usage_count is greater than or + equal to 5". + + If you find the disambiguating structures to be distracting or + confusing, you can also the "simple_expression_query" in + File::KDBX::Util function as a more intuitive alternative. The + following example is equivalent to the previous: + + my $entries = $kdbx->entries->where(simple_expression_query(5, '>=', qw[usage_count])); + + Declarative Syntax + + Structuring a declarative query is similar to "WHERE CLAUSES" in + SQL::Abstract, but you don't have to be familiar with that module. Just + learn by examples here. + + To search for all entries in a database titled "My Bank": + + my $entries = $kdbx->entries->where({ title => 'My Bank' }); + + The query here is { title => 'My Bank' }. A hashref can contain + key-value pairs where the key is an attribute of the thing being + searched for (in this case an entry) and the value is what you want the + thing's attribute to be to consider it a match. In this case, the + attribute we're using as our match criteria is "title" in + File::KDBX::Entry, a text field. If an entry has its title attribute + equal to "My Bank", it's a match. + + A hashref can contain multiple attributes. The search candidate will be + a match if all of the specified attributes are equal to their + respective values. For example, to search for all entries with a + particular URL AND username: + + my $entries = $kdbx->entries->where({ + url => 'https://example.com', + username => 'neo', + }); + + To search for entries matching any criteria, just change the hashref to + an arrayref. To search for entries with a particular URL OR username: + + my $entries = $kdbx->entries->where([ # <-- Notice the square bracket + url => 'https://example.com', + username => 'neo', + ]); + + You can use different operators to test different types of attributes. + The "icon_id" in File::KDBX::Entry attribute is a number, so we should + use a number comparison operator. To find entries using the smartphone + icon: + + my $entries = $kdbx->entries->where({ + icon_id => { '==', ICON_SMARTPHONE }, + }); + + Note: "ICON_SMARTPHONE" in File::KDBX::Constants is just a constant + from File::KDBX::Constants. It isn't special to this example or to + queries generally. We could have just used a literal number. + + The important thing to notice here is how we wrapped the condition in + another arrayref with a single key-value pair where the key is the name + of an operator and the value is the thing to match against. The + supported operators are: + + * eq - String equal + + * ne - String not equal + + * lt - String less than + + * gt - String greater than + + * le - String less than or equal + + * ge - String greater than or equal + + * == - Number equal + + * != - Number not equal + + * < - Number less than + + * >> - Number greater than + + * <= - Number less than or equal + + * >= - Number less than or equal + + * =~ - String match regular expression + + * !~ - String does not match regular expression + + * ! - Boolean false + + * !! - Boolean true + + Other special operators: + + * -true - Boolean true + + * -false - Boolean false + + * -not - Boolean false (alias for -false) + + * -defined - Is defined + + * -undef - Is not defined + + * -empty - Is empty + + * -nonempty - Is not empty + + * -or - Logical or + + * -and - Logical and + + Let's see another example using an explicit operator. To find all + groups except one in particular (identified by its "uuid" in + File::KDBX::Group), we can use the ne (string not equal) operator: + + my $groups = $kdbx->groups->where( + uuid => { + 'ne' => uuid('596f7520-6172-6520-7370-656369616c2e'), + }, + ); + + Note: "uuid" in File::KDBX::Util is a little utility function to + convert a UUID in its pretty form into bytes. This utility function + isn't special to this example or to queries generally. It could have + been written with a literal such as "\x59\x6f\x75\x20\x61...", but + that's harder to read. + + Notice we searched for groups this time. Finding groups works exactly + the same as it does for entries. + + Notice also that we didn't wrap the query in hashref curly-braces or + arrayref square-braces. Those are optional. By default it will only + match ALL attributes (as if there were curly-braces). + + Testing the truthiness of an attribute is a little bit different + because it isn't a binary operation. To find all entries with the + password quality check disabled: + + my $entries = $kdbx->entries->where('!' => 'quality_check'); + + This time the string after the operator is the attribute name rather + than a value to compare the attribute against. To test that a boolean + value is true, use the !! operator (or -true if !! seems a little too + weird for your taste): + + my $entries = $kdbx->entries->where('!!' => 'quality_check'); + my $entries = $kdbx->entries->where(-true => 'quality_check'); # same thing + + Yes, there is also a -false and a -not if you prefer one of those over + !. -false and -not (along with -true) are also special in that you can + use them to invert the logic of a subquery. These are logically + equivalent: + + my $entries = $kdbx->entries->where(-not => { title => 'My Bank' }); + my $entries = $kdbx->entries->where(title => { 'ne' => 'My Bank' }); + + These special operators become more useful when combined with two more + special operators: -and and -or. With these, it is possible to + construct more interesting queries with groups of logic. For example: + + my $entries = $kdbx->entries->where({ + title => { '=~', qr/bank/ }, + -not => { + -or => { + notes => { '=~', qr/business/ }, + icon_id => { '==', ICON_TRASHCAN_FULL }, + }, + }, + }); + + In English, find entries where the word "bank" appears anywhere in the + title but also do not have either the word "business" in the notes or + are using the full trashcan icon. + + Subroutine Query + + Lastly, as mentioned at the top, you can ignore all this and write your + own subroutine. Your subroutine will be called once for each object + being searched over. The subroutine should match the candidate against + whatever criteria you want and return true if it matches or false to + skip. To do this, just pass your subroutine coderef to where. + + To review the different types of queries, these are all equivalent to + find all entries in the database titled "My Bank": + + my $entries = $kdbx->entries->where(\'"My Bank"', 'eq', qw[title]); # simple expression + my $entries = $kdbx->entries->where(title => 'My Bank'); # declarative syntax + my $entries = $kdbx->entries->where(sub { $_->title eq 'My Bank' }); # subroutine query + + This is a trivial example, but of course your subroutine can be + arbitrarily complex. + + All of these query mechanisms described in this section are just tools, + each with its own set of limitations. If the tools are getting in your + way, you can of course iterate over the contents of a database and + implement your own query logic, like this: + + my $entries = $kdbx->entries; + while (my $entry = $entries->next) { + if (wanted($entry)) { + do_something($entry); + } + else { + ... + } + } + + Iteration + + Iterators are the built-in way to navigate or walk the database tree. + You get an iterator from "entries", "groups" and "objects". You can + specify the search algorithm to iterate over objects in different + orders using the algorith option, which can be one of these constants: + + * ITERATION_IDS - Iterative deepening search (default) + + * ITERATION_DFS - Depth-first search + + * ITERATION_BFS - Breadth-first search + + When iterating over objects generically, groups always precede their + direct entries (if any). When the history option is used, current + entries always precede historical entries. + + If you have a database tree like this: + + Database + - Root + - Group1 + - EntryA + - Group2 + - EntryB + - Group3 + - EntryC + + IDS order of groups is: Root, Group1, Group2, Group3 IDS order of + entries is: EntryA, EntryB, EntryC IDS order of objects is: Root, + Group1, EntryA, Group2, EntryB, Group3, EntryC + + DFS order of groups is: Group2, Group1, Group3, Root DFS order of + entries is: EntryB, EntryA, EntryC DFS order of objects is: Group2, + EntryB, Group1, EntryA, Group3, EntryC, Root + + BFS order of groups is: Root, Group1, Group3, Group2 BFS order of + entries is: EntryA, EntryC, EntryB BFS order of objects is: Root, + Group1, EntryA, Group3, EntryC, Group2, EntryB + +SYNCHRONIZING + + TODO - This is a planned feature, not yet implemented. + +ERRORS + + Errors in this package are constructed as File::KDBX::Error objects and + propagated using perl's built-in mechanisms. Fatal errors are + propagated using "die" in functions and non-fatal errors (a.k.a. + warnings) are propagated using "warn" in functions while adhering to + perl's warnings system. If you're already familiar with these + mechanisms, you can skip this section. + + You can catch fatal errors using "eval" in functions (or something like + Try::Tiny) and non-fatal errors using $SIG{__WARN__} (see "%SIG" in + variables). Examples: + + use File::KDBX::Error qw(error); + + my $key = ''; # uh oh + eval { + $kdbx->load_file('whatever.kdbx', $key); + }; + if (my $error = error($@)) { + handle_missing_key($error) if $error->type eq 'key.missing'; + $error->throw; + } + + or using Try::Tiny: + + try { + $kdbx->load_file('whatever.kdbx', $key); + } + catch { + handle_error($_); + }; + + Catching non-fatal errors: + + my @warnings; + local $SIG{__WARN__} = sub { push @warnings, $_[0] }; + + $kdbx->load_file('whatever.kdbx', $key); + + handle_warnings(@warnings) if @warnings; + + By default perl prints warnings to STDERR if you don't catch them. If + you don't want to catch them and also don't want them printed to + STDERR, you can suppress them lexically (perl v5.28 or higher + required): + + { + no warnings 'File::KDBX'; + ... + } + + or locally: + + { + local $File::KDBX::WARNINGS = 0; + ... + } + + or globally in your program: + + $File::KDBX::WARNINGS = 0; + + You cannot suppress fatal errors, and if you don't catch them your + program will exit. + +ENVIRONMENT + + This software will alter its behavior depending on the value of certain + environment variables: + + * PERL_FILE_KDBX_XS - Do not use File::KDBX::XS if false (default: + true) + + * PERL_ONLY - Do not use File::KDBX::XS if true (default: false) + + * NO_FORK - Do not fork if true (default: false) + +CAVEATS + + Some features (e.g. parsing) require 64-bit perl. It should be possible + and actually pretty easy to make it work using Math::BigInt, but I need + to build a 32-bit perl in order to test it and frankly I'm still + figuring out how. I'm sure it's simple so I'll mark this one "TODO", + but for now an exception will be thrown when trying to use such + features with undersized IVs. + +SEE ALSO + + * KeePass Password Safe - The original + KeePass + + * KeePassXC - Cross-Platform Password + Manager written in C++ + + * File::KeePass has overlapping functionality. It's good but has a + backlog of some pretty critical bugs and lacks support for newer KDBX + features. + +BUGS + + Please report any bugs or feature requests on the bugtracker website + https://github.com/chazmcgarvey/File-KDBX/issues + + When submitting a bug or request, please include a test-file or a patch + to an existing test-file that illustrates the bug or desired feature. + +AUTHOR + + Charles McGarvey + +COPYRIGHT AND LICENSE + + This software is copyright (c) 2022 by Charles McGarvey. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + diff --git a/lib/File/KDBX.pm b/lib/File/KDBX.pm new file mode 100644 index 0000000..d7b0d31 --- /dev/null +++ b/lib/File/KDBX.pm @@ -0,0 +1,2807 @@ +package File::KDBX; +# ABSTRACT: Encrypted database to store secret text and files + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use Crypt::PRNG qw(random_bytes); +use Devel::GlobalDestruction; +use File::KDBX::Constants qw(:all :icon); +use File::KDBX::Error; +use File::KDBX::Safe; +use File::KDBX::Util qw(:class :coercion :empty :search :uuid erase simple_expression_query snakify); +use Hash::Util::FieldHash qw(fieldhashes); +use List::Util qw(any first); +use Ref::Util qw(is_ref is_arrayref is_plain_hashref); +use Scalar::Util qw(blessed); +use Time::Piece; +use boolean; +use namespace::clean; + +our $VERSION = '0.800'; # VERSION +our $WARNINGS = 1; + +fieldhashes \my (%SAFE, %KEYS); + + +sub new { + my $class = shift; + + # copy constructor + return $_[0]->clone if @_ == 1 && blessed $_[0] && $_[0]->isa($class); + + my $self = bless {}, $class; + $self->init(@_); + $self->_set_nonlazy_attributes if empty $self; + return $self; +} + +sub DESTROY { local ($., $@, $!, $^E, $?); !in_global_destruction and $_[0]->reset } + + +sub init { + my $self = shift; + my %args = @_; + + @$self{keys %args} = values %args; + + return $self; +} + + +sub reset { + my $self = shift; + erase $self->headers->{+HEADER_INNER_RANDOM_STREAM_KEY}; + erase $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY}; + erase $self->{raw}; + %$self = (); + $self->_remove_safe; + return $self; +} + + +sub clone { + my $self = shift; + require Storable; + return Storable::dclone($self); +} + +sub STORABLE_freeze { + my $self = shift; + my $cloning = shift; + + my $copy = {%$self}; + + return '', $copy, $KEYS{$self} // (), $SAFE{$self} // (); +} + +sub STORABLE_thaw { + my $self = shift; + my $cloning = shift; + shift; + my $clone = shift; + my $key = shift; + my $safe = shift; + + @$self{keys %$clone} = values %$clone; + $KEYS{$self} = $key; + $SAFE{$self} = $safe; + + # Dualvars aren't cloned as dualvars, so coerce the compression flags. + $self->compression_flags($self->compression_flags); + + $self->objects(history => 1)->each(sub { $_->kdbx($self) }); +} + +############################################################################## + + +sub load { shift->_loader->load(@_) } +sub load_string { shift->_loader->load_string(@_) } +sub load_file { shift->_loader->load_file(@_) } +sub load_handle { shift->_loader->load_handle(@_) } + +sub _loader { + my $self = shift; + $self = $self->new if !ref $self; + require File::KDBX::Loader; + File::KDBX::Loader->new(kdbx => $self); +} + + +sub dump { shift->_dumper->dump(@_) } +sub dump_string { shift->_dumper->dump_string(@_) } +sub dump_file { shift->_dumper->dump_file(@_) } +sub dump_handle { shift->_dumper->dump_handle(@_) } + +sub _dumper { + my $self = shift; + $self = $self->new if !ref $self; + require File::KDBX::Dumper; + File::KDBX::Dumper->new(kdbx => $self); +} + +############################################################################## + + +sub user_agent_string { + require Config; + sprintf('%s/%s (%s/%s; %s/%s; %s)', + __PACKAGE__, $VERSION, @Config::Config{qw(package version osname osvers archname)}); +} + +has sig1 => KDBX_SIG1, coerce => \&to_number; +has sig2 => KDBX_SIG2_2, coerce => \&to_number; +has version => KDBX_VERSION_3_1, coerce => \&to_number; +has headers => {}; +has inner_headers => {}; +has meta => {}; +has binaries => {}; +has deleted_objects => {}; +has raw => coerce => \&to_string; + +# HEADERS +has 'headers.comment' => '', coerce => \&to_string; +has 'headers.cipher_id' => CIPHER_UUID_CHACHA20, coerce => \&to_uuid; +has 'headers.compression_flags' => COMPRESSION_GZIP, coerce => \&to_compression_constant; +has 'headers.master_seed' => sub { random_bytes(32) }, coerce => \&to_string; +has 'headers.encryption_iv' => sub { random_bytes(16) }, coerce => \&to_string; +has 'headers.stream_start_bytes' => sub { random_bytes(32) }, coerce => \&to_string; +has 'headers.kdf_parameters' => sub { + +{ + KDF_PARAM_UUID() => KDF_UUID_AES, + KDF_PARAM_AES_ROUNDS() => $_[0]->headers->{+HEADER_TRANSFORM_ROUNDS} // KDF_DEFAULT_AES_ROUNDS, + KDF_PARAM_AES_SEED() => $_[0]->headers->{+HEADER_TRANSFORM_SEED} // random_bytes(32), + }; +}; +# has 'headers.transform_seed' => sub { random_bytes(32) }; +# has 'headers.transform_rounds' => 100_000; +# has 'headers.inner_random_stream_key' => sub { random_bytes(32) }; # 64 ? +# has 'headers.inner_random_stream_id' => STREAM_ID_CHACHA20; +# has 'headers.public_custom_data' => {}; + +# META +has 'meta.generator' => '', coerce => \&to_string; +has 'meta.header_hash' => '', coerce => \&to_string; +has 'meta.database_name' => '', coerce => \&to_string; +has 'meta.database_name_changed' => sub { gmtime }, coerce => \&to_time; +has 'meta.database_description' => '', coerce => \&to_string; +has 'meta.database_description_changed' => sub { gmtime }, coerce => \&to_time; +has 'meta.default_username' => '', coerce => \&to_string; +has 'meta.default_username_changed' => sub { gmtime }, coerce => \&to_time; +has 'meta.maintenance_history_days' => 0, coerce => \&to_number; +has 'meta.color' => '', coerce => \&to_string; +has 'meta.master_key_changed' => sub { gmtime }, coerce => \&to_time; +has 'meta.master_key_change_rec' => -1, coerce => \&to_number; +has 'meta.master_key_change_force' => -1, coerce => \&to_number; +# has 'meta.memory_protection' => {}; +has 'meta.custom_icons' => []; +has 'meta.recycle_bin_enabled' => true, coerce => \&to_bool; +has 'meta.recycle_bin_uuid' => UUID_NULL, coerce => \&to_uuid; +has 'meta.recycle_bin_changed' => sub { gmtime }, coerce => \&to_time; +has 'meta.entry_templates_group' => UUID_NULL, coerce => \&to_uuid; +has 'meta.entry_templates_group_changed' => sub { gmtime }, coerce => \&to_time; +has 'meta.last_selected_group' => UUID_NULL, coerce => \&to_uuid; +has 'meta.last_top_visible_group' => UUID_NULL, coerce => \&to_uuid; +has 'meta.history_max_items' => HISTORY_DEFAULT_MAX_ITEMS, coerce => \&to_number; +has 'meta.history_max_size' => HISTORY_DEFAULT_MAX_SIZE, coerce => \&to_number; +has 'meta.settings_changed' => sub { gmtime }, coerce => \&to_time; +# has 'meta.binaries' => {}; +# has 'meta.custom_data' => {}; + +has 'memory_protection.protect_title' => false, coerce => \&to_bool; +has 'memory_protection.protect_username' => false, coerce => \&to_bool; +has 'memory_protection.protect_password' => true, coerce => \&to_bool; +has 'memory_protection.protect_url' => false, coerce => \&to_bool; +has 'memory_protection.protect_notes' => false, coerce => \&to_bool; +# has 'memory_protection.auto_enable_visual_hiding' => false; + +my @ATTRS = ( + HEADER_TRANSFORM_SEED, + HEADER_TRANSFORM_ROUNDS, + HEADER_INNER_RANDOM_STREAM_KEY, + HEADER_INNER_RANDOM_STREAM_ID, + HEADER_PUBLIC_CUSTOM_DATA, +); +sub _set_nonlazy_attributes { + my $self = shift; + $self->$_ for list_attributes(ref $self), @ATTRS; +} + + +sub memory_protection { + my $self = shift; + $self->{meta}{memory_protection} = shift if @_ == 1 && is_plain_hashref($_[0]); + return $self->{meta}{memory_protection} //= {} if !@_; + + my $string_key = shift; + my $key = 'protect_' . lc($string_key); + + $self->meta->{memory_protection}{$key} = shift if @_; + $self->meta->{memory_protection}{$key}; +} + + +sub minimum_version { + my $self = shift; + + return KDBX_VERSION_4_1 if any { + nonempty $_->{last_modification_time} + } values %{$self->custom_data}; + + return KDBX_VERSION_4_1 if any { + nonempty $_->{name} || nonempty $_->{last_modification_time} + } @{$self->custom_icons}; + + return KDBX_VERSION_4_1 if $self->groups->next(sub { + nonempty $_->previous_parent_group || + nonempty $_->tags || + (any { nonempty $_->{last_modification_time} } values %{$_->custom_data}) + }); + + return KDBX_VERSION_4_1 if $self->entries(history => 1)->next(sub { + nonempty $_->previous_parent_group || + (defined $_->quality_check && !$_->quality_check) || + (any { nonempty $_->{last_modification_time} } values %{$_->custom_data}) + }); + + return KDBX_VERSION_4_0 if $self->kdf->uuid ne KDF_UUID_AES; + + return KDBX_VERSION_4_0 if nonempty $self->public_custom_data; + + return KDBX_VERSION_4_0 if $self->objects->next(sub { + nonempty $_->custom_data + }); + + return KDBX_VERSION_3_1; +} + +############################################################################## + + +sub root { + my $self = shift; + if (@_) { + $self->{root} = $self->_wrap_group(@_); + $self->{root}->kdbx($self); + } + $self->{root} //= $self->_implicit_root; + return $self->_wrap_group($self->{root}); +} + +# Called by File::KeePass::KDBX so that a File::KDBX an be treated as a File::KDBX::Group in that both types +# can have subgroups. File::KDBX already has a `groups' method that does something different from the +# File::KDBX::Groups `groups' method. +sub _kpx_groups { + my $self = shift; + return [] if !$self->{root}; + return $self->_has_implicit_root ? $self->root->groups : [$self->root]; +} + +sub _has_implicit_root { + my $self = shift; + my $root = $self->root; + my $temp = __PACKAGE__->_implicit_root; + # If an implicit root group has been changed in any significant way, it is no longer implicit. + return $root->name eq $temp->name && + $root->is_expanded ^ $temp->is_expanded && + $root->notes eq $temp->notes && + !@{$root->entries} && + !defined $root->custom_icon_uuid && + !keys %{$root->custom_data} && + $root->icon_id == $temp->icon_id && + $root->expires ^ $temp->expires && + $root->default_auto_type_sequence eq $temp->default_auto_type_sequence && + !defined $root->enable_auto_type && + !defined $root->enable_searching; +} + +sub _implicit_root { + my $self = shift; + require File::KDBX::Group; + return File::KDBX::Group->new( + name => 'Root', + is_expanded => true, + notes => 'Added as an implicit root group by '.__PACKAGE__.'.', + ref $self ? (kdbx => $self) : (), + ); +} + + +sub trace_lineage { + my $self = shift; + my $object = shift; + return $object->lineage(@_); +} + +sub _trace_lineage { + my $self = shift; + my $object = shift; + my @lineage = @_; + + push @lineage, $self->root if !@lineage; + my $base = $lineage[-1] or return []; + + my $uuid = $object->uuid; + return \@lineage if any { $_->uuid eq $uuid } @{$base->groups}, @{$base->entries}; + + for my $subgroup (@{$base->groups}) { + my $result = $self->_trace_lineage($object, @lineage, $subgroup); + return $result if $result; + } +} + + +sub recycle_bin { + my $self = shift; + if (my $group = shift) { + $self->recycle_bin_uuid($group->uuid); + return $group; + } + my $group; + my $uuid = $self->recycle_bin_uuid; + $group = $self->groups->grep(uuid => $uuid)->next if $uuid ne UUID_NULL; + if (!$group && $self->recycle_bin_enabled) { + $group = $self->add_group( + name => 'Recycle Bin', + icon_id => ICON_TRASHCAN_FULL, + enable_auto_type => false, + enable_searching => false, + ); + $self->recycle_bin_uuid($group->uuid); + } + return $group; +} + + +sub entry_templates { + my $self = shift; + if (my $group = shift) { + $self->entry_templates_group($group->uuid); + return $group; + } + my $uuid = $self->entry_templates_group; + return if $uuid eq UUID_NULL; + return $self->groups->grep(uuid => $uuid)->next; +} + + +sub last_selected { + my $self = shift; + if (my $group = shift) { + $self->last_selected_group($group->uuid); + return $group; + } + my $uuid = $self->last_selected_group; + return if $uuid eq UUID_NULL; + return $self->groups->grep(uuid => $uuid)->next; +} + + +sub last_top_visible { + my $self = shift; + if (my $group = shift) { + $self->last_top_visible_group($group->uuid); + return $group; + } + my $uuid = $self->last_top_visible_group; + return if $uuid eq UUID_NULL; + return $self->groups->grep(uuid => $uuid)->next; +} + +############################################################################## + + +sub add_group { + my $self = shift; + my $group = @_ % 2 == 1 ? shift : undef; + my %args = @_; + + # find the right group to add the group to + my $parent = delete $args{group} // delete $args{parent} // $self->root; + $parent = $self->groups->grep({uuid => $parent})->next if !ref $parent; + $parent or throw 'Invalid group'; + + return $parent->add_group(defined $group ? $group : (), %args, kdbx => $self); +} + +sub _wrap_group { + my $self = shift; + my $group = shift; + require File::KDBX::Group; + return File::KDBX::Group->wrap($group, $self); +} + + +sub groups { + my $self = shift; + my %args = @_ % 2 == 0 ? @_ : (base => shift, @_); + my $base = delete $args{base} // $self->root; + + return $base->groups_deeply(%args); +} + +############################################################################## + + +sub add_entry { + my $self = shift; + my $entry = @_ % 2 == 1 ? shift : undef; + my %args = @_; + + # find the right group to add the entry to + my $parent = delete $args{group} // delete $args{parent} // $self->root; + $parent = $self->groups->grep({uuid => $parent})->next if !ref $parent; + $parent or throw 'Invalid group'; + + return $parent->add_entry(defined $entry ? $entry : (), %args, kdbx => $self); +} + +sub _wrap_entry { + my $self = shift; + my $entry = shift; + require File::KDBX::Entry; + return File::KDBX::Entry->wrap($entry, $self); +} + + +sub entries { + my $self = shift; + my %args = @_ % 2 == 0 ? @_ : (base => shift, @_); + my $base = delete $args{base} // $self->root; + + return $base->entries_deeply(%args); +} + +############################################################################## + + +sub objects { + my $self = shift; + my %args = @_ % 2 == 0 ? @_ : (base => shift, @_); + my $base = delete $args{base} // $self->root; + + return $base->objects_deeply(%args); +} + +sub __iter__ { $_[0]->objects } + +############################################################################## + + +sub custom_icon { + my $self = shift; + my %args = @_ == 2 ? (uuid => shift, data => shift) + : @_ % 2 == 1 ? (uuid => shift, @_) : @_; + + if (!$args{uuid} && !$args{data}) { + my %standard = (uuid => 1, data => 1, name => 1, last_modification_time => 1); + my @other_keys = grep { !$standard{$_} } keys %args; + if (@other_keys == 1) { + my $key = $args{key} = $other_keys[0]; + $args{data} = delete $args{$key}; + } + } + + my $uuid = $args{uuid} or throw 'Must provide a custom icon UUID to access'; + my $icon = (first { $_->{uuid} eq $uuid } @{$self->custom_icons}) // do { + push @{$self->custom_icons}, my $i = { uuid => $uuid }; + $i; + }; + + my $fields = \%args; + $fields = $args{data} if is_plain_hashref($args{data}); + + while (my ($field, $value) = each %$fields) { + $icon->{$field} = $value; + } + return $icon; +} + + +sub custom_icon_data { + my $self = shift; + my $uuid = shift // return; + my $icon = first { $_->{uuid} eq $uuid } @{$self->custom_icons} or return; + return $icon->{data}; +} + + +sub add_custom_icon { + my $self = shift; + my %args = @_ % 2 == 1 ? (data => shift, @_) : @_; + + defined $args{data} or throw 'Must provide image data'; + + my $uuid = $args{uuid} // generate_uuid; + push @{$self->custom_icons}, { + @_, + uuid => $uuid, + data => $args{data}, + }; + return $uuid; +} + + +sub remove_custom_icon { + my $self = shift; + my $uuid = shift; + my @deleted; + @{$self->custom_icons} = grep { $_->{uuid} eq $uuid ? do { push @deleted, $_; 0 } : 1 } + @{$self->custom_icons}; + $self->add_deleted_object($uuid) if @deleted; + return @deleted; +} + +############################################################################## + + +sub custom_data { + my $self = shift; + $self->{meta}{custom_data} = shift if @_ == 1 && is_plain_hashref($_[0]); + return $self->{meta}{custom_data} //= {} if !@_; + + my %args = @_ == 2 ? (key => shift, value => shift) + : @_ % 2 == 1 ? (key => shift, @_) : @_; + + if (!$args{key} && !$args{value}) { + my %standard = (key => 1, value => 1, last_modification_time => 1); + my @other_keys = grep { !$standard{$_} } keys %args; + if (@other_keys == 1) { + my $key = $args{key} = $other_keys[0]; + $args{value} = delete $args{$key}; + } + } + + my $key = $args{key} or throw 'Must provide a custom_data key to access'; + + return $self->{meta}{custom_data}{$key} = $args{value} if is_plain_hashref($args{value}); + + while (my ($field, $value) = each %args) { + $self->{meta}{custom_data}{$key}{$field} = $value; + } + return $self->{meta}{custom_data}{$key}; +} + + +sub custom_data_value { + my $self = shift; + my $data = $self->custom_data(@_) // return; + return $data->{value}; +} + + +sub public_custom_data { + my $self = shift; + $self->{headers}{+HEADER_PUBLIC_CUSTOM_DATA} = shift if @_ == 1 && is_plain_hashref($_[0]); + return $self->{headers}{+HEADER_PUBLIC_CUSTOM_DATA} //= {} if !@_; + + my $key = shift or throw 'Must provide a public_custom_data key to access'; + $self->{headers}{+HEADER_PUBLIC_CUSTOM_DATA}{$key} = shift if @_; + return $self->{headers}{+HEADER_PUBLIC_CUSTOM_DATA}{$key}; +} + +############################################################################## + +# TODO + +# sub merge_to { +# my $self = shift; +# my $other = shift; +# my %options = @_; # prefer_old / prefer_new +# $other->merge_from($self); +# } + +# sub merge_from { +# my $self = shift; +# my $other = shift; + +# die 'Not implemented'; +# } + + +sub add_deleted_object { + my $self = shift; + my $uuid = shift; + + # ignore null and meta stream UUIDs + return if $uuid eq UUID_NULL || $uuid eq '0' x 16; + + $self->deleted_objects->{$uuid} = { + uuid => $uuid, + deletion_time => scalar gmtime, + }; +} + + +sub remove_deleted_object { + my $self = shift; + my $uuid = shift; + delete $self->deleted_objects->{$uuid}; +} + + +sub clear_deleted_objects { + my $self = shift; + %{$self->deleted_objects} = (); +} + +############################################################################## + + +sub resolve_reference { + my $self = shift; + my $wanted = shift // return; + my $search_in = shift; + my $text = shift; + + if (!defined $text) { + $wanted =~ s/^\{REF:([^\}]+)\}$/$1/i; + ($wanted, $search_in, $text) = $wanted =~ /^([TUPANI])\@([TUPANIO]):(.*)$/i; + } + $wanted && $search_in && nonempty($text) or return; + + my %fields = ( + T => 'expand_title', + U => 'expand_username', + P => 'expand_password', + A => 'expand_url', + N => 'expand_notes', + I => 'uuid', + O => 'other_strings', + ); + $wanted = $fields{$wanted} or return; + $search_in = $fields{$search_in} or return; + + my $query = $search_in eq 'uuid' ? query($search_in => uuid($text)) + : simple_expression_query($text, '=~', $search_in); + + my $entry = $self->entries->grep($query)->next; + $entry or return; + + return $entry->$wanted; +} + +our %PLACEHOLDERS = ( + # 'PLACEHOLDER' => sub { my ($entry, $arg) = @_; ... }; + 'TITLE' => sub { $_[0]->expand_title }, + 'USERNAME' => sub { $_[0]->expand_username }, + 'PASSWORD' => sub { $_[0]->expand_password }, + 'NOTES' => sub { $_[0]->expand_notes }, + 'S:' => sub { $_[0]->string_value($_[1]) }, + 'URL' => sub { $_[0]->expand_url }, + 'URL:RMVSCM' => sub { local $_ = $_[0]->url; s!^[^:/\?\#]+://!!; $_ }, + 'URL:WITHOUTSCHEME' => sub { local $_ = $_[0]->url; s!^[^:/\?\#]+://!!; $_ }, + 'URL:SCM' => sub { (split_url($_[0]->url))[0] }, + 'URL:SCHEME' => sub { (split_url($_[0]->url))[0] }, # non-standard + 'URL:HOST' => sub { (split_url($_[0]->url))[2] }, + 'URL:PORT' => sub { (split_url($_[0]->url))[3] }, + 'URL:PATH' => sub { (split_url($_[0]->url))[4] }, + 'URL:QUERY' => sub { (split_url($_[0]->url))[5] }, + 'URL:HASH' => sub { (split_url($_[0]->url))[6] }, # non-standard + 'URL:FRAGMENT' => sub { (split_url($_[0]->url))[6] }, # non-standard + 'URL:USERINFO' => sub { (split_url($_[0]->url))[1] }, + 'URL:USERNAME' => sub { (split_url($_[0]->url))[7] }, + 'URL:PASSWORD' => sub { (split_url($_[0]->url))[8] }, + 'UUID' => sub { local $_ = format_uuid($_[0]->uuid); s/-//g; $_ }, + 'REF:' => sub { $_[0]->kdbx->resolve_reference($_[1]) }, + 'INTERNETEXPLORER' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('iexplore') }, + 'FIREFOX' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('firefox') }, + 'GOOGLECHROME' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('google-chrome') }, + 'OPERA' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('opera') }, + 'SAFARI' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('safari') }, + 'APPDIR' => sub { load_optional('FindBin'); $FindBin::Bin }, + 'GROUP' => sub { my $p = $_[0]->group; $p ? $p->name : undef }, + 'GROUP_PATH' => sub { $_[0]->path }, + 'GROUP_NOTES' => sub { my $p = $_[0]->group; $p ? $p->notes : undef }, + # 'GROUP_SEL' + # 'GROUP_SEL_PATH' + # 'GROUP_SEL_NOTES' + # 'DB_PATH' + # 'DB_DIR' + # 'DB_NAME' + # 'DB_BASENAME' + # 'DB_EXT' + 'ENV:' => sub { $ENV{$_[1]} }, + 'ENV_DIRSEP' => sub { load_optional('File::Spec')->catfile('', '') }, + 'ENV_PROGRAMFILES_X86' => sub { $ENV{'ProgramFiles(x86)'} || $ENV{'ProgramFiles'} }, + # 'T-REPLACE-RX:' + # 'T-CONV:' + 'DT_SIMPLE' => sub { localtime->strftime('%Y%m%d%H%M%S') }, + 'DT_YEAR' => sub { localtime->strftime('%Y') }, + 'DT_MONTH' => sub { localtime->strftime('%m') }, + 'DT_DAY' => sub { localtime->strftime('%d') }, + 'DT_HOUR' => sub { localtime->strftime('%H') }, + 'DT_MINUTE' => sub { localtime->strftime('%M') }, + 'DT_SECOND' => sub { localtime->strftime('%S') }, + 'DT_UTC_SIMPLE' => sub { gmtime->strftime('%Y%m%d%H%M%S') }, + 'DT_UTC_YEAR' => sub { gmtime->strftime('%Y') }, + 'DT_UTC_MONTH' => sub { gmtime->strftime('%m') }, + 'DT_UTC_DAY' => sub { gmtime->strftime('%d') }, + 'DT_UTC_HOUR' => sub { gmtime->strftime('%H') }, + 'DT_UTC_MINUTE' => sub { gmtime->strftime('%M') }, + 'DT_UTC_SECOND' => sub { gmtime->strftime('%S') }, + # 'PICKCHARS' + # 'PICKCHARS:' + # 'PICKFIELD' + # 'NEWPASSWORD' + # 'NEWPASSWORD:' + # 'PASSWORD_ENC' + 'HMACOTP' => sub { $_[0]->hmac_otp }, + 'TIMEOTP' => sub { $_[0]->time_otp }, + 'C:' => sub { '' }, # comment + # 'BASE' + # 'BASE:' + # 'CLIPBOARD' + # 'CLIPBOARD-SET:' + # 'CMD:' +); + +############################################################################## + + +sub _safe { + my $self = shift; + $SAFE{$self} = shift if @_; + $SAFE{$self}; +} + +sub _remove_safe { delete $SAFE{$_[0]} } + +sub lock { + my $self = shift; + + $self->_safe and return $self; + + my @strings; + + $self->entries(history => 1)->each(sub { + push @strings, grep { $_->{protect} } values %{$_->strings}, values %{$_->binaries}; + }); + + $self->_safe(File::KDBX::Safe->new(\@strings)); + + return $self; +} + + +sub unlock { + my $self = shift; + my $safe = $self->_safe or return $self; + + $safe->unlock; + $self->_remove_safe; + + return $self; +} + + +sub unlock_scoped { + throw 'Programmer error: Cannot call unlock_scoped in void context' if !defined wantarray; + my $self = shift; + return if !$self->is_locked; + require Scope::Guard; + my $guard = Scope::Guard->new(sub { $self->lock }); + $self->unlock; + return $guard; +} + + +sub peek { + my $self = shift; + my $string = shift; + my $safe = $self->_safe or return; + return $safe->peek($string); +} + + +sub is_locked { $_[0]->_safe ? 1 : 0 } + +############################################################################## + +# sub check { +# - Fixer tool. Can repair inconsistencies, including: +# - Orphaned binaries... not really a thing anymore since we now distribute binaries amongst entries +# - Unused custom icons (OFF, data loss) +# - Duplicate icons +# - All data types are valid +# - date times are correct +# - boolean fields +# - All UUIDs refer to things that exist +# - previous parent group +# - recycle bin +# - last selected group +# - last visible group +# - Enforce history size limits (ON) +# - Check headers/meta (ON) +# - Duplicate deleted objects (ON) +# - Duplicate window associations (OFF) +# - Header UUIDs match known ciphers/KDFs? +# } + + +sub remove_empty_groups { + my $self = shift; + my @removed; + $self->groups(algorithm => 'dfs') + ->where(-true => 'is_empty') + ->each(sub { push @removed, $_->remove }); + return @removed; +} + + +sub remove_unused_icons { + my $self = shift; + my %icons = map { $_->{uuid} => 0 } @{$self->custom_icons}; + + $self->objects->each(sub { ++$icons{$_->custom_icon_uuid // ''} }); + + my @removed; + push @removed, $self->remove_custom_icon($_) for grep { $icons{$_} == 0 } keys %icons; + return @removed; +} + + +sub remove_duplicate_icons { + my $self = shift; + + my %seen; + my %dup; + for my $icon (@{$self->custom_icons}) { + my $digest = digest_data('SHA256', $icon->{data}); + if (my $other = $seen{$digest}) { + $dup{$icon->{uuid}} = $other->{uuid}; + } + else { + $seen{$digest} = $icon; + } + } + + my @removed; + while (my ($old_uuid, $new_uuid) = each %dup) { + $self->objects + ->where(custom_icon_uuid => $old_uuid) + ->each(sub { $_->custom_icon_uuid($new_uuid) }); + push @removed, $self->remove_custom_icon($old_uuid); + } + return @removed; +} + + +sub prune_history { + my $self = shift; + my %args = @_; + + my $max_items = $args{max_items} // $self->history_max_items // HISTORY_DEFAULT_MAX_ITEMS; + my $max_size = $args{max_size} // $self->history_max_size // HISTORY_DEFAULT_MAX_SIZE; + my $max_age = $args{max_age} // HISTORY_DEFAULT_MAX_AGE; + + my @removed; + $self->entries->each(sub { + push @removed, $_->prune_history( + max_items => $max_items, + max_size => $max_size, + max_age => $max_age, + ); + }); + return @removed; +} + + +sub randomize_seeds { + my $self = shift; + $self->encryption_iv(random_bytes(16)); + $self->inner_random_stream_key(random_bytes(64)); + $self->master_seed(random_bytes(32)); + $self->stream_start_bytes(random_bytes(32)); + $self->transform_seed(random_bytes(32)); +} + +############################################################################## + + +sub key { + my $self = shift; + $KEYS{$self} = File::KDBX::Key->new(@_) if @_; + $KEYS{$self}; +} + + +sub composite_key { + my $self = shift; + require File::KDBX::Key::Composite; + return File::KDBX::Key::Composite->new(@_); +} + + +sub kdf { + my $self = shift; + my %args = @_ % 2 == 1 ? (params => shift, @_) : @_; + + my $params = $args{params}; + my $compat = $args{compatible} // 1; + + $params //= $self->kdf_parameters; + $params = {%{$params || {}}}; + + if (empty $params || !defined $params->{+KDF_PARAM_UUID}) { + $params->{+KDF_PARAM_UUID} = KDF_UUID_AES; + } + if ($params->{+KDF_PARAM_UUID} eq KDF_UUID_AES) { + # AES_CHALLENGE_RESPONSE is equivalent to AES if there are no challenge-response keys, and since + # non-KeePassXC implementations don't support challenge-response keys anyway, there's no problem with + # always using AES_CHALLENGE_RESPONSE for all KDBX4+ databases. + # For compatibility, we should not *write* AES_CHALLENGE_RESPONSE, but the dumper handles that. + if ($self->version >= KDBX_VERSION_4_0) { + $params->{+KDF_PARAM_UUID} = KDF_UUID_AES_CHALLENGE_RESPONSE; + } + $params->{+KDF_PARAM_AES_SEED} //= $self->transform_seed; + $params->{+KDF_PARAM_AES_ROUNDS} //= $self->transform_rounds; + } + + require File::KDBX::KDF; + return File::KDBX::KDF->new(%$params); +} + +sub transform_seed { + my $self = shift; + $self->headers->{+HEADER_TRANSFORM_SEED} = + $self->headers->{+HEADER_KDF_PARAMETERS}{+KDF_PARAM_AES_SEED} = shift if @_; + $self->headers->{+HEADER_TRANSFORM_SEED} = + $self->headers->{+HEADER_KDF_PARAMETERS}{+KDF_PARAM_AES_SEED} //= random_bytes(32); +} + +sub transform_rounds { + my $self = shift; + $self->headers->{+HEADER_TRANSFORM_ROUNDS} = + $self->headers->{+HEADER_KDF_PARAMETERS}{+KDF_PARAM_AES_ROUNDS} = shift if @_; + $self->headers->{+HEADER_TRANSFORM_ROUNDS} = + $self->headers->{+HEADER_KDF_PARAMETERS}{+KDF_PARAM_AES_ROUNDS} //= 100_000; +} + + +sub cipher { + my $self = shift; + my %args = @_; + + $args{uuid} //= $self->headers->{+HEADER_CIPHER_ID}; + $args{iv} //= $self->headers->{+HEADER_ENCRYPTION_IV}; + + require File::KDBX::Cipher; + return File::KDBX::Cipher->new(%args); +} + + +sub random_stream { + my $self = shift; + my %args = @_; + + $args{stream_id} //= delete $args{id} // $self->inner_random_stream_id; + $args{key} //= $self->inner_random_stream_key; + + require File::KDBX::Cipher; + File::KDBX::Cipher->new(%args); +} + +sub inner_random_stream_id { + my $self = shift; + $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_ID} + = $self->headers->{+HEADER_INNER_RANDOM_STREAM_ID} = shift if @_; + $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_ID} + //= $self->headers->{+HEADER_INNER_RANDOM_STREAM_ID} //= do { + my $version = $self->minimum_version; + $version < KDBX_VERSION_4_0 ? STREAM_ID_SALSA20 : STREAM_ID_CHACHA20; + }; +} + +sub inner_random_stream_key { + my $self = shift; + if (@_) { + # These are probably the same SvPV so erasing one will CoW, but erasing the second should do the + # trick anyway. + erase \$self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY}; + erase \$self->headers->{+HEADER_INNER_RANDOM_STREAM_KEY}; + $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY} + = $self->headers->{+HEADER_INNER_RANDOM_STREAM_KEY} = shift; + } + $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY} + //= $self->headers->{+HEADER_INNER_RANDOM_STREAM_KEY} //= random_bytes(64); # 32 +} + +######################################################################################### + +sub _handle_signal { + my $self = shift; + my $object = shift; + my $type = shift; + + my %handlers = ( + 'entry.added' => \&_handle_object_added, + 'group.added' => \&_handle_object_added, + 'entry.removed' => \&_handle_object_removed, + 'group.removed' => \&_handle_object_removed, + 'entry.uuid.changed' => \&_handle_entry_uuid_changed, + 'group.uuid.changed' => \&_handle_group_uuid_changed, + ); + my $handler = $handlers{$type} or return; + $self->$handler($object, @_); +} + +sub _handle_object_added { + my $self = shift; + my $object = shift; + $self->remove_deleted_object($object->uuid); +} + +sub _handle_object_removed { + my $self = shift; + my $object = shift; + my $old_uuid = $object->{uuid} // return; + + my $meta = $self->meta; + $self->recycle_bin_uuid(UUID_NULL) if $old_uuid eq ($meta->{recycle_bin_uuid} // ''); + $self->entry_templates_group(UUID_NULL) if $old_uuid eq ($meta->{entry_templates_group} // ''); + $self->last_selected_group(UUID_NULL) if $old_uuid eq ($meta->{last_selected_group} // ''); + $self->last_top_visible_group(UUID_NULL) if $old_uuid eq ($meta->{last_top_visible_group} // ''); + + $self->add_deleted_object($old_uuid); +} + +sub _handle_entry_uuid_changed { + my $self = shift; + my $object = shift; + my $new_uuid = shift; + my $old_uuid = shift // return; + + my $old_pretty = format_uuid($old_uuid); + my $new_pretty = format_uuid($new_uuid); + my $fieldref_match = qr/\{REF:([TUPANI])\@I:\Q$old_pretty\E\}/is; + + $self->entries->each(sub { + $_->previous_parent_group($new_uuid) if $old_uuid eq ($_->{previous_parent_group} // ''); + + for my $string (values %{$_->strings}) { + next if !defined $string->{value} || $string->{value} !~ $fieldref_match; + my $txn = $_->begin_work; + $string->{value} =~ s/$fieldref_match/{REF:$1\@I:$new_pretty}/g; + $txn->commit; + } + }); +} + +sub _handle_group_uuid_changed { + my $self = shift; + my $object = shift; + my $new_uuid = shift; + my $old_uuid = shift // return; + + my $meta = $self->meta; + $self->recycle_bin_uuid($new_uuid) if $old_uuid eq ($meta->{recycle_bin_uuid} // ''); + $self->entry_templates_group($new_uuid) if $old_uuid eq ($meta->{entry_templates_group} // ''); + $self->last_selected_group($new_uuid) if $old_uuid eq ($meta->{last_selected_group} // ''); + $self->last_top_visible_group($new_uuid) if $old_uuid eq ($meta->{last_top_visible_group} // ''); + + $self->groups->each(sub { + $_->last_top_visible_entry($new_uuid) if $old_uuid eq ($_->{last_top_visible_entry} // ''); + $_->previous_parent_group($new_uuid) if $old_uuid eq ($_->{previous_parent_group} // ''); + }); + $self->entries->each(sub { + $_->previous_parent_group($new_uuid) if $old_uuid eq ($_->{previous_parent_group} // ''); + }); +} + +######################################################################################### + + +######################################################################################### + +sub TO_JSON { +{%{$_[0]}} } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=for markdown [![Linux](https://github.com/chazmcgarvey/File-KDBX/actions/workflows/linux.yml/badge.svg)](https://github.com/chazmcgarvey/File-KDBX/actions/workflows/linux.yml) +[![macOS](https://github.com/chazmcgarvey/File-KDBX/actions/workflows/macos.yml/badge.svg)](https://github.com/chazmcgarvey/File-KDBX/actions/workflows/macos.yml) +[![Windows](https://github.com/chazmcgarvey/File-KDBX/actions/workflows/windows.yml/badge.svg)](https://github.com/chazmcgarvey/File-KDBX/actions/workflows/windows.yml) + +=for HTML + + + +=head1 NAME + +File::KDBX - Encrypted database to store secret text and files + +=head1 VERSION + +version 0.800 + +=head1 SYNOPSIS + + use File::KDBX; + + my $kdbx = File::KDBX->new; + + my $group = $kdbx->add_group( + name => 'Passwords', + ); + + my $entry = $group->add_entry( + title => 'My Bank', + password => 's3cr3t', + ); + + $kdbx->dump_file('passwords.kdbx', 'M@st3rP@ssw0rd!'); + + $kdbx = File::KDBX->load_file('passwords.kdbx', 'M@st3rP@ssw0rd!'); + + $kdbx->entries->each(sub { + my ($entry) = @_; + say 'Entry: ', $entry->title; + }); + +See L for more examples. + +=head1 DESCRIPTION + +B provides everything you need to work with a KDBX database. A KDBX database is a hierarchical +object database which is commonly used to store secret information securely. It was developed for the KeePass +password safe. See L for more information about KDBX. + +This module lets you query entries, create new entries, delete entries and modify entries. The distribution +also includes various parsers and generators for serializing and persisting databases. + +This design of this software was influenced by the L +implementation of KeePass as well as the L module. B is an alternative module +that works well in most cases but has a small backlog of bugs and security issues and also does not work with +newer KDBX version 4 files. If you're coming here from the B world, you might be interested in +L that is a drop-in replacement for B that uses B for storage. + +This software is a B. The interface should be considered pretty stable, but there might be +minor changes up until a 1.0 release. Breaking changes will be noted in the F file. + +=head2 Features + +This implementation of KDBX supports a lot of features: + +=over 4 + +=item * + +☑ Read and write KDBX version 3 - version 4.1 + +=item * + +☑ Read and write KDB files (requires L) + +=item * + +☑ Unicode character strings + +=item * + +☑ L Searching + +=item * + +☑ L and L + +=item * + +☑ L + +=item * + +☑ L + +=item * + +☑ L + +=item * + +☑ Challenge-response key components, like L + +=item * + +☑ Variety of L types: binary, hexed, hashed, XML v1 and v2 + +=item * + +☑ Pluggable registration of different kinds of ciphers and key derivation functions + +=item * + +☑ Built-in database maintenance functions + +=item * + +☑ Pretty fast, with L available + +=item * + +☒ Database synchronization / merging (not yet) + +=back + +=head2 Introduction to KDBX + +A KDBX database consists of a tree of I and I, with a single I group. Entries can +contain zero or more key-value pairs of I and zero or more I (i.e. octet strings). Groups, +entries, strings and binaries: that's the KDBX vernacular. A small amount of metadata (timestamps, etc.) is +associated with each entry, group and the database as a whole. + +You can think of a KDBX database kind of like a file system, where groups are directories, entries are files, +and strings and binaries make up a file's contents. + +Databases are typically persisted as a encrypted, compressed files. They are usually accessed directly (i.e. +not over a network). The primary focus of this type of database is data security. It is ideal for storing +relatively small amounts of data (strings and binaries) that must remain secret except to such individuals as +have the correct I. Even if the database file were to be "leaked" to the public Internet, it +should be virtually impossible to crack with a strong key. The KDBX format is most often used by password +managers to store passwords so that users can know a single strong password and not have to reuse passwords +across different websites. See L for an overview of security considerations. + +=head1 ATTRIBUTES + +=head2 sig1 + +=head2 sig2 + +=head2 version + +=head2 headers + +=head2 inner_headers + +=head2 meta + +=head2 binaries + +=head2 deleted_objects + +Hash of UUIDs for objects that have been deleted. This includes groups, entries and even custom icons. + +=head2 raw + +Bytes contained within the encrypted layer of a KDBX file. This is only set when using +L. + +=head2 comment + +A text string associated with the database. Often unset. + +=head2 cipher_id + +The UUID of a cipher used to encrypt the database when stored as a file. + +See L. + +=head2 compression_flags + +Configuration for whether or not and how the database gets compressed. See +L. + +=head2 master_seed + +The master seed is a string of 32 random bytes that is used as salt in hashing the master key when loading +and saving the database. If a challenge-response key is used in the master key, the master seed is also the +challenge. + +The master seed I be changed each time the database is saved to file. + +=head2 transform_seed + +The transform seed is a string of 32 random bytes that is used in the key derivation function, either as the +salt or the key (depending on the algorithm). + +The transform seed I be changed each time the database is saved to file. + +=head2 transform_rounds + +The number of rounds or iterations used in the key derivation function. Increasing this number makes loading +and saving the database slower by design in order to make dictionary and brute force attacks more costly. + +=head2 encryption_iv + +The initialization vector used by the cipher. + +The encryption IV I be changed each time the database is saved to file. + +=head2 inner_random_stream_key + +The encryption key (possibly including the IV, depending on the cipher) used to encrypt the protected strings +within the database. + +=head2 stream_start_bytes + +A string of 32 random bytes written in the header and encrypted in the body. If the bytes do not match when +loading a file then the wrong master key was used or the file is corrupt. Only KDBX 2 and KDBX 3 files use +this. KDBX 4 files use an improved HMAC method to verify the master key and data integrity of the header and +entire file body. + +=head2 inner_random_stream_id + +A number indicating the cipher algorithm used to encrypt the protected strings within the database, usually +Salsa20 or ChaCha20. See L. + +=head2 kdf_parameters + +A hash/dict of key-value pairs used to configure the key derivation function. This is the KDBX4+ way to +configure the KDF, superceding L and L. + +=head2 generator + +The name of the software used to generate the KDBX file. + +=head2 header_hash + +The header hash used to verify that the file header is not corrupt. (KDBX 2 - KDBX 3.1, removed KDBX 4.0) + +=head2 database_name + +Name of the database. + +=head2 database_name_changed + +Timestamp indicating when the database name was last changed. + +=head2 database_description + +Description of the database + +=head2 database_description_changed + +Timestamp indicating when the database description was last changed. + +=head2 default_username + +When a new entry is created, the I string will be populated with this value. + +=head2 default_username_changed + +Timestamp indicating when the default username was last changed. + +=head2 maintenance_history_days + +TODO... not really sure what this is. 😀 + +=head2 color + +A color associated with the database (in the form C<#ffffff> where "f" is a hexidecimal digit). Some agents +use this to help users visually distinguish between different databases. + +=head2 master_key_changed + +Timestamp indicating when the master key was last changed. + +=head2 master_key_change_rec + +Number of days until the agent should prompt to recommend changing the master key. + +=head2 master_key_change_force + +Number of days until the agent should prompt to force changing the master key. + +Note: This is purely advisory. It is up to the individual agent software to actually enforce it. +C does NOT enforce it. + +=head2 custom_icons + +Array of custom icons that can be associated with groups and entries. + +This list can be managed with the methods L and L. + +=head2 recycle_bin_enabled + +Boolean indicating whether removed groups and entries should go to a recycle bin or be immediately deleted. + +=head2 recycle_bin_uuid + +The UUID of a group used to store thrown-away groups and entries. + +=head2 recycle_bin_changed + +Timestamp indicating when the recycle bin was last changed. + +=head2 entry_templates_group + +The UUID of a group containing template entries used when creating new entries. + +=head2 entry_templates_group_changed + +Timestamp indicating when the entry templates group was last changed. + +=head2 last_selected_group + +The UUID of the previously-selected group. + +=head2 last_top_visible_group + +The UUID of the group visible at the top of the list. + +=head2 history_max_items + +The maximum number of historical entries allowed to be saved for each entry. + +=head2 history_max_size + +The maximum total size (in bytes) that each individual entry's history is allowed to grow. + +=head2 settings_changed + +Timestamp indicating when the database settings were last updated. + +=head2 protect_title + +Alias of the L setting for the I string. + +=head2 protect_username + +Alias of the L</memory_protection> setting for the I<UserName> string. + +=head2 protect_password + +Alias of the L</memory_protection> setting for the I<Password> string. + +=head2 protect_url + +Alias of the L</memory_protection> setting for the I<URL> string. + +=head2 protect_notes + +Alias of the L</memory_protection> setting for the I<Notes> string. + +=head1 METHODS + +=head2 new + + $kdbx = File::KDBX->new(%attributes); + $kdbx = File::KDBX->new($kdbx); # copy constructor + +Construct a new L<File::KDBX>. + +=head2 init + + $kdbx = $kdbx->init(%attributes); + +Initialize a L<File::KDBX> with a set of attributes. Returns itself to allow method chaining. + +This is called by L</new>. + +=head2 reset + + $kdbx = $kdbx->reset; + +Set a L<File::KDBX> to an empty state, ready to load a KDBX file or build a new one. Returns itself to allow +method chaining. + +=head2 clone + + $kdbx_copy = $kdbx->clone; + $kdbx_copy = File::KDBX->new($kdbx); + +Clone a L<File::KDBX>. The clone will be an exact copy and completely independent of the original. + +=head2 load + +=head2 load_string + +=head2 load_file + +=head2 load_handle + + $kdbx = KDBX::File->load(\$string, $key); + $kdbx = KDBX::File->load(*IO, $key); + $kdbx = KDBX::File->load($filepath, $key); + $kdbx->load(...); # also instance method + + $kdbx = File::KDBX->load_string($string, $key); + $kdbx = File::KDBX->load_string(\$string, $key); + $kdbx->load_string(...); # also instance method + + $kdbx = File::KDBX->load_file($filepath, $key); + $kdbx->load_file(...); # also instance method + + $kdbx = File::KDBX->load_handle($fh, $key); + $kdbx = File::KDBX->load_handle(*IO, $key); + $kdbx->load_handle(...); # also instance method + +Load a KDBX file from a string buffer, IO handle or file from a filesystem. + +L<File::KDBX::Loader> does the heavy lifting. + +=head2 dump + +=head2 dump_string + +=head2 dump_file + +=head2 dump_handle + + $kdbx->dump(\$string, $key); + $kdbx->dump(*IO, $key); + $kdbx->dump($filepath, $key); + + $kdbx->dump_string(\$string, $key); + \$string = $kdbx->dump_string($key); + + $kdbx->dump_file($filepath, $key); + + $kdbx->dump_handle($fh, $key); + $kdbx->dump_handle(*IO, $key); + +Dump a KDBX file to a string buffer, IO handle or file in a filesystem. + +L<File::KDBX::Dumper> does the heavy lifting. + +=head2 user_agent_string + + $string = $kdbx->user_agent_string; + +Get a text string identifying the database client software. + +=head2 memory_protection + + \%settings = $kdbx->memory_protection + $kdbx->memory_protection(\%settings); + + $bool = $kdbx->memory_protection($string_key); + $kdbx->memory_protection($string_key => $bool); + +Get or set memory protection settings. This globally (for the whole database) configures whether and which of +the standard strings should be memory-protected. The default setting is to memory-protect only I<Password> +strings. + +Memory protection can be toggled individually for each entry string, and individual settings take precedence +over these global settings. + +=head2 minimum_version + + $version = $kdbx->minimum_version; + +Determine the minimum file version required to save a database losslessly. Using certain databases features +might increase this value. For example, setting the KDF to Argon2 will increase the minimum version to at +least C<KDBX_VERSION_4_0> (i.e. C<0x00040000>) because Argon2 was introduced with KDBX4. + +This method never returns less than C<KDBX_VERSION_3_1> (i.e. C<0x00030001>). That file version is so +ubiquitious and well-supported, there are seldom reasons to dump in a lesser format nowadays. + +B<WARNING:> If you dump a database with a minimum version higher than the current L</version>, the dumper will +typically issue a warning and automatically upgrade the database. This seems like the safest behavior in order +to avoid data loss, but lower versions have the benefit of being compatible with more software. It is possible +to prevent auto-upgrades by explicitly telling the dumper which version to use, but you do run the risk of +data loss. A database will never be automatically downgraded. + +=head2 root + + $group = $kdbx->root; + $kdbx->root($group); + +Get or set a database's root group. You don't necessarily need to explicitly create or set a root group +because it autovivifies when adding entries and groups to the database. + +Every database has only a single root group at a time. Some old KDB files might have multiple root groups. +When reading such files, a single implicit root group is created to contain the actual root groups. When +writing to such a format, if the root group looks like it was implicitly created then it won't be written and +the resulting file might have multiple root groups. This allows working with older files without changing +their written internal structure while still adhering to modern semantics while the database is opened. + +The root group of a KDBX database contains all of the database's entries and other groups. If you replace the +root group, you are essentially replacing the entire database contents with something else. + +=head2 trace_lineage + + \@lineage = $kdbx->trace_lineage($group); + \@lineage = $kdbx->trace_lineage($group, $base_group); + \@lineage = $kdbx->trace_lineage($entry); + \@lineage = $kdbx->trace_lineage($entry, $base_group); + +Get the direct line of ancestors from C<$base_group> (default: the root group) to a group or entry. The +lineage includes the base group but I<not> the target group or entry. Returns C<undef> if the target is not in +the database structure. + +=head2 recycle_bin + + $group = $kdbx->recycle_bin; + $kdbx->recycle_bin($group); + +Get or set the recycle bin group. Returns C<undef> if there is no recycle bin and L</recycle_bin_enabled> is +false, otherwise the current recycle bin or an autovivified recycle bin group is returned. + +=head2 entry_templates + + $group = $kdbx->entry_templates; + $kdbx->entry_templates($group); + +Get or set the entry templates group. May return C<undef> if unset. + +=head2 last_selected + + $group = $kdbx->last_selected; + $kdbx->last_selected($group); + +Get or set the last selected group. May return C<undef> if unset. + +=head2 last_top_visible + + $group = $kdbx->last_top_visible; + $kdbx->last_top_visible($group); + +Get or set the last top visible group. May return C<undef> if unset. + +=head2 add_group + + $kdbx->add_group($group); + $kdbx->add_group(%group_attributes, %options); + +Add a group to a database. This is equivalent to identifying a parent group and calling +L<File::KDBX::Group/add_group> on the parent group, forwarding the arguments. Available options: + +=over 4 + +=item * + +C<group> (aka C<parent>) - Group object or group UUID to add the group to (default: root group) + +=back + +=head2 groups + + \&iterator = $kdbx->groups(%options); + \&iterator = $kdbx->groups($base_group, %options); + +Get an L<File::KDBX::Iterator> over I<groups> within a database. Options: + +=over 4 + +=item * + +C<base> - Only include groups within a base group (same as C<$base_group>) (default: L</root>) + +=item * + +C<inclusive> - Include the base group in the results (default: true) + +=item * + +C<algorithm> - Search algorithm, one of C<ids>, C<bfs> or C<dfs> (default: C<ids>) + +=back + +=head2 add_entry + + $kdbx->add_entry($entry, %options); + $kdbx->add_entry(%entry_attributes, %options); + +Add a entry to a database. This is equivalent to identifying a parent group and calling +L<File::KDBX::Group/add_entry> on the parent group, forwarding the arguments. Available options: + +=over 4 + +=item * + +C<group> (aka C<parent>) - Group object or group UUID to add the entry to (default: root group) + +=back + +=head2 entries + + \&iterator = $kdbx->entries(%options); + \&iterator = $kdbx->entries($base_group, %options); + +Get an L<File::KDBX::Iterator> over I<entries> within a database. Supports the same options as L</groups>, +plus some new ones: + +=over 4 + +=item * + +C<auto_type> - Only include entries with auto-type enabled (default: false, include all) + +=item * + +C<searching> - Only include entries within groups with searching enabled (default: false, include all) + +=item * + +C<history> - Also include historical entries (default: false, include only current entries) + +=back + +=head2 objects + + \&iterator = $kdbx->objects(%options); + \&iterator = $kdbx->objects($base_group, %options); + +Get an L<File::KDBX::Iterator> over I<objects> within a database. Groups and entries are considered objects, +so this is essentially a combination of L</groups> and L</entries>. This won't often be useful, but it can be +convenient for maintenance tasks. This method takes the same options as L</groups> and L</entries>. + +=head2 custom_icon + + \%icon = $kdbx->custom_icon($uuid); + $kdbx->custom_icon($uuid => \%icon); + $kdbx->custom_icon(%icon); + $kdbx->custom_icon(uuid => $value, %icon); + +Get or set custom icons. + +=head2 custom_icon_data + + $image_data = $kdbx->custom_icon_data($uuid); + +Get a custom icon image data. + +=head2 add_custom_icon + + $uuid = $kdbx->add_custom_icon($image_data, %attributes); + $uuid = $kdbx->add_custom_icon(%attributes); + +Add a custom icon and get its UUID. If not provided, a random UUID will be generated. Possible attributes: + +=over 4 + +=item * + +C<uuid> - Icon UUID (default: autogenerated) + +=item * + +C<data> - Image data (same as C<$image_data>) + +=item * + +C<name> - Name of the icon (text, KDBX4.1+) + +=item * + +C<last_modification_time> - Just what it says (datetime, KDBX4.1+) + +=back + +=head2 remove_custom_icon + + $kdbx->remove_custom_icon($uuid); + +Remove a custom icon. + +=head2 custom_data + + \%all_data = $kdbx->custom_data; + $kdbx->custom_data(\%all_data); + + \%data = $kdbx->custom_data($key); + $kdbx->custom_data($key => \%data); + $kdbx->custom_data(%data); + $kdbx->custom_data(key => $value, %data); + +Get and set custom data. Custom data is metadata associated with a database. + +Each data item can have a few attributes associated with it. + +=over 4 + +=item * + +C<key> - A unique text string identifier used to look up the data item (required) + +=item * + +C<value> - A text string value (required) + +=item * + +C<last_modification_time> (optional, KDBX4.1+) + +=back + +=head2 custom_data_value + + $value = $kdbx->custom_data_value($key); + +Exactly the same as L</custom_data> except returns just the custom data's value rather than a structure of +attributes. This is a shortcut for: + + my $data = $kdbx->custom_data($key); + my $value = defined $data ? $data->{value} : undef; + +=head2 public_custom_data + + \%all_data = $kdbx->public_custom_data; + $kdbx->public_custom_data(\%all_data); + + $value = $kdbx->public_custom_data($key); + $kdbx->public_custom_data($key => $value); + +Get and set public custom data. Public custom data is similar to custom data but different in some important +ways. Public custom data: + +=over 4 + +=item * + +can store strings, booleans and up to 64-bit integer values (custom data can only store text values) + +=item * + +is NOT encrypted within a KDBX file (hence the "public" part of the name) + +=item * + +is a plain hash/dict of key-value pairs with no other associated fields (like modification times) + +=back + +=head2 add_deleted_object + + $kdbx->add_deleted_object($uuid); + +Add a UUID to the deleted objects list. This list is used to support automatic database merging. + +You typically do not need to call this yourself because the list will be populated automatically as objects +are removed. + +=head2 remove_deleted_object + + $kdbx->remove_deleted_object($uuid); + +Remove a UUID from the deleted objects list. This list is used to support automatic database merging. + +You typically do not need to call this yourself because the list will be maintained automatically as objects +are added. + +=head2 clear_deleted_objects + +Remove all UUIDs from the deleted objects list. This list is used to support automatic database merging, but +if you don't need merging then you can clear deleted objects to reduce the database file size. + +=head2 resolve_reference + + $string = $kdbx->resolve_reference($reference); + $string = $kdbx->resolve_reference($wanted, $search_in, $expression); + +Resolve a L<field reference|https://keepass.info/help/base/fieldrefs.html>. A field reference is a kind of +string placeholder. You can use a field reference to refer directly to a standard field within an entry. Field +references are resolved automatically while expanding entry strings (i.e. replacing placeholders), but you can +use this method to resolve on-the-fly references that aren't part of any actual string in the database. + +If the reference does not resolve to any field, C<undef> is returned. If the reference resolves to multiple +fields, only the first one is returned (in the same order as iterated by L</entries>). To avoid ambiguity, you +can refer to a specific entry by its UUID. + +The syntax of a reference is: C<< {REF:<WantedField>@<SearchIn>:<Text>} >>. C<Text> is a +L</"Simple Expression">. C<WantedField> and C<SearchIn> are both single character codes representing a field: + +=over 4 + +=item * + +C<T> - Title + +=item * + +C<U> - UserName + +=item * + +C<P> - Password + +=item * + +C<A> - URL + +=item * + +C<N> - Notes + +=item * + +C<I> - UUID + +=item * + +C<O> - Other custom strings + +=back + +Since C<O> does not represent any specific field, it cannot be used as the C<WantedField>. + +Examples: + +To get the value of the I<UserName> string of the first entry with "My Bank" in the title: + + my $username = $kdbx->resolve_reference('{REF:U@T:"My Bank"}'); + # OR the {REF:...} wrapper is optional + my $username = $kdbx->resolve_reference('U@T:"My Bank"'); + # OR separate the arguments + my $username = $kdbx->resolve_reference(U => T => '"My Bank"'); + +Note how the text is a L</"Simple Expression">, so search terms with spaces must be surrounded in double +quotes. + +To get the I<Password> string of a specific entry (identified by its UUID): + + my $password = $kdbx->resolve_reference('{REF:P@I:46C9B1FFBD4ABC4BBB260C6190BAD20C}'); + +=head2 lock + + $kdbx->lock; + +Encrypt all protected binaries strings in a database. The encrypted strings are stored in +a L<File::KDBX::Safe> associated with the database and the actual strings will be replaced with C<undef> to +indicate their protected state. Returns itself to allow method chaining. + +You can call C<code> on an already-locked database to memory-protect any unprotected strings and binaries +added after the last time the database was locked. + +=head2 unlock + + $kdbx->unlock; + +Decrypt all protected strings in a database, replacing C<undef> placeholders with unprotected values. Returns +itself to allow method chaining. + +=head2 unlock_scoped + + $guard = $kdbx->unlock_scoped; + +Unlock a database temporarily, relocking when the guard is released (typically at the end of a scope). Returns +C<undef> if the database is already unlocked. + +See L</lock> and L</unlock>. + +=head2 peek + + $string = $kdbx->peek(\%string); + $string = $kdbx->peek(\%binary); + +Peek at the value of a protected string or binary without unlocking the whole database. The argument can be +a string or binary hashref as returned by L<File::KDBX::Entry/string> or L<File::KDBX::Entry/binary>. + +=head2 is_locked + + $bool = $kdbx->is_locked; + +Get whether or not a database's strings are memory-protected. If this is true, then some or all of the +protected strings within the database will be unavailable (literally have C<undef> values) until L</unlock> is +called. + +=head2 remove_empty_groups + + $kdbx->remove_empty_groups; + +Remove groups with no subgroups and no entries. + +=head2 remove_unused_icons + + $kdbx->remove_unused_icons; + +Remove icons that are not associated with any entry or group in the database. + +=head2 remove_duplicate_icons + + $kdbx->remove_duplicate_icons; + +Remove duplicate icons as determined by hashing the icon data. + +=head2 prune_history + + $kdbx->prune_history(%options); + +Remove just as many older historical entries as necessary to get under certain limits. + +=over 4 + +=item * + +C<max_items> - Maximum number of historical entries to keep (default: value of L</history_max_items>, no limit: -1) + +=item * + +C<max_size> - Maximum total size (in bytes) of historical entries to keep (default: value of L</history_max_size>, no limit: -1) + +=item * + +C<max_age> - Maximum age (in days) of historical entries to keep (default: 365, no limit: -1) + +=back + +=head2 randomize_seeds + + $kdbx->randomize_seeds; + +Set various keys, seeds and IVs to random values. These values are used by the cryptographic functions that +secure the database when dumped. The attributes that will be randomized are: + +=over 4 + +=item * + +L</encryption_iv> + +=item * + +L</inner_random_stream_key> + +=item * + +L</master_seed> + +=item * + +L</stream_start_bytes> + +=item * + +L</transform_seed> + +=back + +Randomizing these values has no effect on a loaded database. These are only used when a database is dumped. +You normally do not need to call this method explicitly because the dumper does it explicitly by default. + +=head2 key + + $key = $kdbx->key; + $key = $kdbx->key($key); + $key = $kdbx->key($primitive); + +Get or set a L<File::KDBX::Key>. This is the master key (e.g. a password or a key file that can decrypt +a database). See L<File::KDBX::Key/new> for an explanation of what the primitive can be. + +You generally don't need to call this directly because you can provide the key directly to the loader or +dumper when loading or dumping a KDBX file. + +=head2 composite_key + + $key = $kdbx->composite_key($key); + $key = $kdbx->composite_key($primitive); + +Construct a L<File::KDBX::Key::Composite> from a primitive. See L<File::KDBX::Key/new> for an explanation of +what the primitive can be. If the primitive does not represent a composite key, it will be wrapped. + +You generally don't need to call this directly. The parser and writer use it to transform a master key into +a raw encryption key. + +=head2 kdf + + $kdf = $kdbx->kdf(%options); + $kdf = $kdbx->kdf(\%parameters, %options); + +Get a L<File::KDBX::KDF> (key derivation function). + +Options: + +=over 4 + +=item * + +C<params> - KDF parameters, same as C<\%parameters> (default: value of L</kdf_parameters>) + +=back + +=head2 cipher + + $cipher = $kdbx->cipher(key => $key); + $cipher = $kdbx->cipher(key => $key, iv => $iv, uuid => $uuid); + +Get a L<File::KDBX::Cipher> capable of encrypting and decrypting the body of a database file. + +A key is required. This should be a raw encryption key made up of a fixed number of octets (depending on the +cipher), not a L<File::KDBX::Key> or primitive. + +If not passed, the UUID comes from C<< $kdbx->headers->{cipher_id} >> and the encryption IV comes from +C<< $kdbx->headers->{encryption_iv} >>. + +You generally don't need to call this directly. The parser and writer use it to decrypt and encrypt KDBX +files. + +=head2 random_stream + + $cipher = $kdbx->random_stream; + $cipher = $kdbx->random_stream(id => $stream_id, key => $key); + +Get a L<File::KDBX::Cipher::Stream> for decrypting and encrypting protected values. + +If not passed, the ID and encryption key comes from C<< $kdbx->headers->{inner_random_stream_id} >> and +C<< $kdbx->headers->{inner_random_stream_key} >> (respectively) for KDBX3 files and from +C<< $kdbx->inner_headers->{inner_random_stream_key} >> and +C<< $kdbx->inner_headers->{inner_random_stream_id} >> (respectively) for KDBX4 files. + +You generally don't need to call this directly. The parser and writer use it to scramble protected strings. + +=for Pod::Coverage STORABLE_freeze STORABLE_thaw TO_JSON + +=head1 RECIPES + +=head2 Create a new database + + my $kdbx = File::KDBX->new; + + my $group = $kdbx->add_group(name => 'Passwords); + my $entry = $group->add_entry( + title => 'WayneCorp', + username => 'bwayne', + password => 'iambatman', + url => 'https://example.com/login' + ); + $entry->add_auto_type_window_association('WayneCorp - Mozilla Firefox', '{PASSWORD}{ENTER}'); + + $kdbx->dump_file('mypasswords.kdbx', 'master password CHANGEME'); + +=head2 Read an existing database + + my $kdbx = File::KDBX->load_file('mypasswords.kdbx', 'master password CHANGEME'); + $kdbx->unlock; # cause $entry->password below to be defined + + $kdbx->entries->each(sub { + my ($entry) = @_; + say 'Found password for: ', $entry->title; + say ' Username: ', $entry->username; + say ' Password: ', $entry->password; + }); + +=head2 Search for entries + + my @entries = $kdbx->entries(searching => 1) + ->grep(title => 'WayneCorp') + ->each; # return all matches + +The C<searching> option limits results to only entries within groups with searching enabled. Other options are +also available. See L</entries>. + +See L</QUERY> for many more query examples. + +=head2 Search for entries by auto-type window association + + my $window_title = 'WayneCorp - Mozilla Firefox'; + + my $entries = $kdbx->entries(auto_type => 1) + ->filter(sub { + my ($ata) = grep { $_->{window} =~ /\Q$window_title\E/i } @{$_->auto_type_associations}; + return [$_, $ata->{keystroke_sequence}] if $ata; + }) + ->each(sub { + my ($entry, $keys) = @$_; + say 'Entry title: ', $entry->title, ', key sequence: ', $keys; + }); + +Example output: + + Entry title: WayneCorp, key sequence: {PASSWORD}{ENTER} + +=head2 Remove entries from a database + + $kdbx->entries + ->grep(notes => {'=~' => qr/too old/i}) + ->each(sub { $_->recycle }); + +Recycle all entries with the string "too old" appearing in the B<Notes> string. + +=head2 Remove empty groups + + $kdbx->groups(algorithm => 'dfs') + ->where(-true => 'is_empty') + ->each('remove'); + +With the search/iteration C<algorithm> set to "dfs", groups will be ordered deepest first and the root group +will be last. This allows removing groups that only contain empty groups. + +This can also be done with one call to L</remove_empty_groups>. + +=head1 SECURITY + +One of the biggest threats to your database security is how easily the encryption key can be brute-forced. +Strong brute-force protection depends on: + +=over 4 + +=item * + +Using unguessable passwords, passphrases and key files. + +=item * + +Using a brute-force resistent key derivation function. + +=back + +The first factor is up to you. This module does not enforce strong master keys. It is up to you to pick or +generate strong keys. + +The KDBX format allows for the key derivation function to be tuned. The idea is that you want each single +brute-foce attempt to be expensive (in terms of time, CPU usage or memory usage), so that making a lot of +attempts (which would be required if you have a strong master key) gets I<really> expensive. + +How expensive you want to make each attempt is up to you and can depend on the application. + +This and other KDBX-related security issues are covered here more in depth: +L<https://keepass.info/help/base/security.html> + +Here are other security risks you should be thinking about: + +=head2 Cryptography + +This distribution uses the excellent L<CryptX> and L<Crypt::Argon2> packages to handle all crypto-related +functions. As such, a lot of the security depends on the quality of these dependencies. Fortunately these +modules are maintained and appear to have good track records. + +The KDBX format has evolved over time to incorporate improved security practices and cryptographic functions. +This package uses the following functions for authentication, hashing, encryption and random number +generation: + +=over 4 + +=item * + +AES-128 (legacy) + +=item * + +AES-256 + +=item * + +Argon2d & Argon2id + +=item * + +CBC block mode + +=item * + +HMAC-SHA256 + +=item * + +SHA256 + +=item * + +SHA512 + +=item * + +Salsa20 & ChaCha20 + +=item * + +Twofish + +=back + +At the time of this writing, I am not aware of any successful attacks against any of these functions. These +are among the most-analyzed and widely-adopted crypto functions available. + +The KDBX format allows the body cipher and key derivation function to be configured. If a flaw is discovered +in one of these functions, you can hopefully just switch to a better function without needing to update this +software. A later software release may phase out the use of any functions which are no longer secure. + +=head2 Memory Protection + +It is not a good idea to keep secret information unencrypted in system memory for longer than is needed. The +address space of your program can generally be read by a user with elevated privileges on the system. If your +system is memory-constrained or goes into a hibernation mode, the contents of your address space could be +written to a disk where it might be persisted for long time. + +There might be system-level things you can do to reduce your risk, like using swap encryption and limiting +system access to your program's address space while your program is running. + +B<File::KDBX> helps minimize (but not eliminate) risk by keeping secrets encrypted in memory until accessed +and zeroing out memory that holds secrets after they're no longer needed, but it's not a silver bullet. + +For one thing, the encryption key is stored in the same address space. If core is dumped, the encryption key +is available to be found out. But at least there is the chance that the encryption key and the encrypted +secrets won't both be paged out together while memory-constrained. + +Another problem is that some perls (somewhat notoriously) copy around memory behind the scenes willy nilly, +and it's difficult know when perl makes a copy of a secret in order to be able to zero it out later. It might +be impossible. The good news is that perls with SvPV copy-on-write (enabled by default beginning with perl +5.20) are much better in this regard. With COW, it's mostly possible to know what operations will cause perl +to copy the memory of a scalar string, and the number of copies will be significantly reduced. There is a unit +test named F<t/memory-protection.t> in this distribution that can be run on POSIX systems to determine how +well B<File::KDBX> memory protection is working. + +Memory protection also depends on how your application handles secrets. If your app code is handling scalar +strings with secret information, it's up to you to make sure its memory is zeroed out when no longer needed. +L<File::KDBX::Util/erase> et al. provide some tools to help accomplish this. Or if you're not too concerned +about the risks memory protection is meant to mitigate, then maybe don't worry about it. The security policy +of B<File::KDBX> is to try hard to keep secrets protected while in memory so that your app might claim a high +level of security, in case you care about that. + +There are some memory protection strategies that B<File::KDBX> does NOT use today but could in the future: + +Many systems allow programs to mark unswappable pages. Secret information should ideally be stored in such +pages. You could potentially use L<mlockall(2)> (or equivalent for your system) in your own application to +prevent the entire address space from being swapped. + +Some systems provide special syscalls for storing secrets in memory while keeping the encryption key outside +of the program's address space, like C<CryptProtectMemory> for Windows. This could be a good option, though +unfortunately not portable. + +=head1 QUERY + +To find things in a KDBX database, you should use a filtered iterator. If you have an iterator, such as +returned by L</entries>, L</groups> or even L</objects> you can filter it using L<File::KDBX::Iterator/where>. + + my $filtered_entries = $kdbx->entries->where($query); + +A C<$query> is just a subroutine that you can either write yourself or have generated for you from either +a L</"Simple Expression"> or L</"Declarative Syntax">. It's easier to have your query generated, so I'll cover +that first. + +=head2 Simple Expression + +A simple expression is mostly compatible with the KeePass 2 implementation +L<described here|https://keepass.info/help/base/search.html#mode_se>. + +An expression is a string with one or more space-separated terms. Terms with spaces can be enclosed in double +quotes. Terms are negated if they are prefixed with a minus sign. A record must match every term on at least +one of the given fields. + +So a simple expression is something like what you might type into a search engine. You can generate a simple +expression query using L<File::KDBX::Util/simple_expression_query> or by passing the simple expression as +a B<scalar reference> to C<where>. + +To search for all entries in a database with the word "canyon" appearing anywhere in the title: + + my $entries = $kdbx->entries->where(\'canyon', qw[title]); + +Notice the first argument is a B<scalarref>. This disambiguates a simple expression from other types of +queries covered below. + +As mentioned, a simple expression can have multiple terms. This simple expression query matches any entry that +has the words "red" B<and> "canyon" anywhere in the title: + + my $entries = $kdbx->entries->where(\'red canyon', qw[title]); + +Each term in the simple expression must be found for an entry to match. + +To search for entries with "red" in the title but B<not> "canyon", just prepend "canyon" with a minus sign: + + my $entries = $kdbx->entries->where(\'red -canyon', qw[title]); + +To search over multiple fields simultaneously, just list them all. To search for entries with "grocery" (but +not "Foodland") in the title or notes: + + my $entries = $kdbx->entries->where(\'grocery -Foodland', qw[title notes]); + +The default operator is a case-insensitive regexp match, which is fine for searching text loosely. You can use +just about any binary comparison operator that perl supports. To specify an operator, list it after the simple +expression. For example, to search for any entry that has been used at least five times: + + my $entries = $kdbx->entries->where(\5, '>=', qw[usage_count]); + +It helps to read it right-to-left, like "usage_count is greater than or equal to 5". + +If you find the disambiguating structures to be distracting or confusing, you can also the +L<File::KDBX::Util/simple_expression_query> function as a more intuitive alternative. The following example is +equivalent to the previous: + + my $entries = $kdbx->entries->where(simple_expression_query(5, '>=', qw[usage_count])); + +=head2 Declarative Syntax + +Structuring a declarative query is similar to L<SQL::Abstract/"WHERE CLAUSES">, but you don't have to be +familiar with that module. Just learn by examples here. + +To search for all entries in a database titled "My Bank": + + my $entries = $kdbx->entries->where({ title => 'My Bank' }); + +The query here is C<< { title => 'My Bank' } >>. A hashref can contain key-value pairs where the key is an +attribute of the thing being searched for (in this case an entry) and the value is what you want the thing's +attribute to be to consider it a match. In this case, the attribute we're using as our match criteria is +L<File::KDBX::Entry/title>, a text field. If an entry has its title attribute equal to "My Bank", it's +a match. + +A hashref can contain multiple attributes. The search candidate will be a match if I<all> of the specified +attributes are equal to their respective values. For example, to search for all entries with a particular URL +B<AND> username: + + my $entries = $kdbx->entries->where({ + url => 'https://example.com', + username => 'neo', + }); + +To search for entries matching I<any> criteria, just change the hashref to an arrayref. To search for entries +with a particular URL B<OR> username: + + my $entries = $kdbx->entries->where([ # <-- Notice the square bracket + url => 'https://example.com', + username => 'neo', + ]); + +You can use different operators to test different types of attributes. The L<File::KDBX::Entry/icon_id> +attribute is a number, so we should use a number comparison operator. To find entries using the smartphone +icon: + + my $entries = $kdbx->entries->where({ + icon_id => { '==', ICON_SMARTPHONE }, + }); + +Note: L<File::KDBX::Constants/ICON_SMARTPHONE> is just a constant from L<File::KDBX::Constants>. It isn't +special to this example or to queries generally. We could have just used a literal number. + +The important thing to notice here is how we wrapped the condition in another arrayref with a single key-value +pair where the key is the name of an operator and the value is the thing to match against. The supported +operators are: + +=over 4 + +=item * + +C<eq> - String equal + +=item * + +C<ne> - String not equal + +=item * + +C<lt> - String less than + +=item * + +C<gt> - String greater than + +=item * + +C<le> - String less than or equal + +=item * + +C<ge> - String greater than or equal + +=item * + +C<==> - Number equal + +=item * + +C<!=> - Number not equal + +=item * + +C<< < >> - Number less than + +=item * + +C<< > >>> - Number greater than + +=item * + +C<< <= >> - Number less than or equal + +=item * + +C<< >= >> - Number less than or equal + +=item * + +C<=~> - String match regular expression + +=item * + +C<!~> - String does not match regular expression + +=item * + +C<!> - Boolean false + +=item * + +C<!!> - Boolean true + +=back + +Other special operators: + +=over 4 + +=item * + +C<-true> - Boolean true + +=item * + +C<-false> - Boolean false + +=item * + +C<-not> - Boolean false (alias for C<-false>) + +=item * + +C<-defined> - Is defined + +=item * + +C<-undef> - Is not defined + +=item * + +C<-empty> - Is empty + +=item * + +C<-nonempty> - Is not empty + +=item * + +C<-or> - Logical or + +=item * + +C<-and> - Logical and + +=back + +Let's see another example using an explicit operator. To find all groups except one in particular (identified +by its L<File::KDBX::Group/uuid>), we can use the C<ne> (string not equal) operator: + + my $groups = $kdbx->groups->where( + uuid => { + 'ne' => uuid('596f7520-6172-6520-7370-656369616c2e'), + }, + ); + +Note: L<File::KDBX::Util/uuid> is a little utility function to convert a UUID in its pretty form into bytes. +This utility function isn't special to this example or to queries generally. It could have been written with +a literal such as C<"\x59\x6f\x75\x20\x61...">, but that's harder to read. + +Notice we searched for groups this time. Finding groups works exactly the same as it does for entries. + +Notice also that we didn't wrap the query in hashref curly-braces or arrayref square-braces. Those are +optional. By default it will only match ALL attributes (as if there were curly-braces). + +Testing the truthiness of an attribute is a little bit different because it isn't a binary operation. To find +all entries with the password quality check disabled: + + my $entries = $kdbx->entries->where('!' => 'quality_check'); + +This time the string after the operator is the attribute name rather than a value to compare the attribute +against. To test that a boolean value is true, use the C<!!> operator (or C<-true> if C<!!> seems a little too +weird for your taste): + + my $entries = $kdbx->entries->where('!!' => 'quality_check'); + my $entries = $kdbx->entries->where(-true => 'quality_check'); # same thing + +Yes, there is also a C<-false> and a C<-not> if you prefer one of those over C<!>. C<-false> and C<-not> +(along with C<-true>) are also special in that you can use them to invert the logic of a subquery. These are +logically equivalent: + + my $entries = $kdbx->entries->where(-not => { title => 'My Bank' }); + my $entries = $kdbx->entries->where(title => { 'ne' => 'My Bank' }); + +These special operators become more useful when combined with two more special operators: C<-and> and C<-or>. +With these, it is possible to construct more interesting queries with groups of logic. For example: + + my $entries = $kdbx->entries->where({ + title => { '=~', qr/bank/ }, + -not => { + -or => { + notes => { '=~', qr/business/ }, + icon_id => { '==', ICON_TRASHCAN_FULL }, + }, + }, + }); + +In English, find entries where the word "bank" appears anywhere in the title but also do not have either the +word "business" in the notes or are using the full trashcan icon. + +=head2 Subroutine Query + +Lastly, as mentioned at the top, you can ignore all this and write your own subroutine. Your subroutine will +be called once for each object being searched over. The subroutine should match the candidate against whatever +criteria you want and return true if it matches or false to skip. To do this, just pass your subroutine +coderef to C<where>. + +To review the different types of queries, these are all equivalent to find all entries in the database titled +"My Bank": + + my $entries = $kdbx->entries->where(\'"My Bank"', 'eq', qw[title]); # simple expression + my $entries = $kdbx->entries->where(title => 'My Bank'); # declarative syntax + my $entries = $kdbx->entries->where(sub { $_->title eq 'My Bank' }); # subroutine query + +This is a trivial example, but of course your subroutine can be arbitrarily complex. + +All of these query mechanisms described in this section are just tools, each with its own set of limitations. +If the tools are getting in your way, you can of course iterate over the contents of a database and implement +your own query logic, like this: + + my $entries = $kdbx->entries; + while (my $entry = $entries->next) { + if (wanted($entry)) { + do_something($entry); + } + else { + ... + } + } + +=head2 Iteration + +Iterators are the built-in way to navigate or walk the database tree. You get an iterator from L</entries>, +L</groups> and L</objects>. You can specify the search algorithm to iterate over objects in different orders +using the C<algorith> option, which can be one of these L<constants|File::KDBX::Constants/":iteration">: + +=over 4 + +=item * + +C<ITERATION_IDS> - Iterative deepening search (default) + +=item * + +C<ITERATION_DFS> - Depth-first search + +=item * + +C<ITERATION_BFS> - Breadth-first search + +=back + +When iterating over objects generically, groups always precede their direct entries (if any). When the +C<history> option is used, current entries always precede historical entries. + +If you have a database tree like this: + + Database + - Root + - Group1 + - EntryA + - Group2 + - EntryB + - Group3 + - EntryC + +IDS order of groups is: Root, Group1, Group2, Group3 +IDS order of entries is: EntryA, EntryB, EntryC +IDS order of objects is: Root, Group1, EntryA, Group2, EntryB, Group3, EntryC + +DFS order of groups is: Group2, Group1, Group3, Root +DFS order of entries is: EntryB, EntryA, EntryC +DFS order of objects is: Group2, EntryB, Group1, EntryA, Group3, EntryC, Root + +BFS order of groups is: Root, Group1, Group3, Group2 +BFS order of entries is: EntryA, EntryC, EntryB +BFS order of objects is: Root, Group1, EntryA, Group3, EntryC, Group2, EntryB + +=head1 SYNCHRONIZING + +B<TODO> - This is a planned feature, not yet implemented. + +=head1 ERRORS + +Errors in this package are constructed as L<File::KDBX::Error> objects and propagated using perl's built-in +mechanisms. Fatal errors are propagated using L<functions/die> and non-fatal errors (a.k.a. warnings) are +propagated using L<functions/warn> while adhering to perl's L<warnings> system. If you're already familiar +with these mechanisms, you can skip this section. + +You can catch fatal errors using L<functions/eval> (or something like L<Try::Tiny>) and non-fatal errors using +C<$SIG{__WARN__}> (see L<variables/%SIG>). Examples: + + use File::KDBX::Error qw(error); + + my $key = ''; # uh oh + eval { + $kdbx->load_file('whatever.kdbx', $key); + }; + if (my $error = error($@)) { + handle_missing_key($error) if $error->type eq 'key.missing'; + $error->throw; + } + +or using C<Try::Tiny>: + + try { + $kdbx->load_file('whatever.kdbx', $key); + } + catch { + handle_error($_); + }; + +Catching non-fatal errors: + + my @warnings; + local $SIG{__WARN__} = sub { push @warnings, $_[0] }; + + $kdbx->load_file('whatever.kdbx', $key); + + handle_warnings(@warnings) if @warnings; + +By default perl prints warnings to C<STDERR> if you don't catch them. If you don't want to catch them and also +don't want them printed to C<STDERR>, you can suppress them lexically (perl v5.28 or higher required): + + { + no warnings 'File::KDBX'; + ... + } + +or locally: + + { + local $File::KDBX::WARNINGS = 0; + ... + } + +or globally in your program: + + $File::KDBX::WARNINGS = 0; + +You cannot suppress fatal errors, and if you don't catch them your program will exit. + +=head1 ENVIRONMENT + +This software will alter its behavior depending on the value of certain environment variables: + +=over 4 + +=item * + +C<PERL_FILE_KDBX_XS> - Do not use L<File::KDBX::XS> if false (default: true) + +=item * + +C<PERL_ONLY> - Do not use L<File::KDBX::XS> if true (default: false) + +=item * + +C<NO_FORK> - Do not fork if true (default: false) + +=back + +=head1 CAVEATS + +Some features (e.g. parsing) require 64-bit perl. It should be possible and actually pretty easy to make it +work using L<Math::BigInt>, but I need to build a 32-bit perl in order to test it and frankly I'm still +figuring out how. I'm sure it's simple so I'll mark this one "TODO", but for now an exception will be thrown +when trying to use such features with undersized IVs. + +=head1 SEE ALSO + +=over 4 + +=item * + +L<KeePass Password Safe|https://keepass.info/> - The original KeePass + +=item * + +L<KeePassXC|https://keepassxc.org/> - Cross-Platform Password Manager written in C++ + +=item * + +L<File::KeePass> has overlapping functionality. It's good but has a backlog of some pretty critical bugs and lacks support for newer KDBX features. + +=back + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Cipher.pm b/lib/File/KDBX/Cipher.pm new file mode 100644 index 0000000..0253376 --- /dev/null +++ b/lib/File/KDBX/Cipher.pm @@ -0,0 +1,378 @@ +package File::KDBX::Cipher; +# ABSTRACT: A block cipher mode or cipher stream + +use warnings; +use strict; + +use Devel::GlobalDestruction; +use File::KDBX::Constants qw(:cipher :random_stream); +use File::KDBX::Error; +use File::KDBX::Util qw(:class erase format_uuid); +use Module::Load; +use Scalar::Util qw(looks_like_number); +use namespace::clean; + +our $VERSION = '0.800'; # VERSION + +my %CIPHERS; + + +has 'uuid', is => 'ro'; +has 'stream_id', is => 'ro'; +has 'key', is => 'ro'; +has 'iv', is => 'ro'; +sub iv_size { 0 } +sub key_size { -1 } +sub block_size { 0 } +sub algorithm { $_[0]->{algorithm} or throw 'Block cipher algorithm is not set' } + + +sub new { + my $class = shift; + my %args = @_; + + return $class->new_from_uuid(delete $args{uuid}, %args) if defined $args{uuid}; + return $class->new_from_stream_id(delete $args{stream_id}, %args) if defined $args{stream_id}; + + throw 'Must pass uuid or stream_id'; +} + +sub new_from_uuid { + my $class = shift; + my $uuid = shift; + my %args = @_; + + $args{key} or throw 'Missing encryption key'; + $args{iv} or throw 'Missing encryption IV'; + + my $formatted_uuid = format_uuid($uuid); + + my $cipher = $CIPHERS{$uuid} or throw "Unsupported cipher ($formatted_uuid)", uuid => $uuid; + ($class, my %registration_args) = @$cipher; + + my @args = (%args, %registration_args, uuid => $uuid); + load $class; + my $self = bless {@args}, $class; + return $self->init(@args); +} + +sub new_from_stream_id { + my $class = shift; + my $id = shift; + my %args = @_; + + $args{key} or throw 'Missing encryption key'; + + my $cipher = $CIPHERS{$id} or throw "Unsupported stream cipher ($id)", id => $id; + ($class, my %registration_args) = @$cipher; + + my @args = (%args, %registration_args, stream_id => $id); + load $class; + my $self = bless {@args}, $class; + return $self->init(@args); +} + + +sub init { $_[0] } + +sub DESTROY { !in_global_destruction and erase \$_[0]->{key} } + + +sub encrypt { die 'Not implemented' } + + +sub decrypt { die 'Not implemented' } + + +sub finish { '' } + + +sub encrypt_finish { + my $self = shift; + my $out = $self->encrypt(@_); + $out .= $self->finish; + return $out; +} + + +sub decrypt_finish { + my $self = shift; + my $out = $self->decrypt(@_); + $out .= $self->finish; + return $out; +} + + +sub register { + my $class = shift; + my $id = shift; + my $package = shift; + my @args = @_; + + my $formatted_id = looks_like_number($id) ? $id : format_uuid($id); + $package = "${class}::${package}" if $package !~ s/^\+// && $package !~ /^\Q${class}::\E/; + + my %blacklist = map { (looks_like_number($_) ? $_ : File::KDBX::Util::uuid($_)) => 1 } + split(/,/, $ENV{FILE_KDBX_CIPHER_BLACKLIST} // ''); + if ($blacklist{$id} || $blacklist{$package}) { + alert "Ignoring blacklisted cipher ($formatted_id)", id => $id, package => $package; + return; + } + + if (defined $CIPHERS{$id}) { + alert "Overriding already-registered cipher ($formatted_id) with package $package", + id => $id, + package => $package; + } + + $CIPHERS{$id} = [$package, @args]; +} + + +sub unregister { + delete $CIPHERS{$_} for @_; +} + +BEGIN { + __PACKAGE__->register(CIPHER_UUID_AES128, 'CBC', algorithm => 'AES', key_size => 16); + __PACKAGE__->register(CIPHER_UUID_AES256, 'CBC', algorithm => 'AES', key_size => 32); + __PACKAGE__->register(CIPHER_UUID_SERPENT, 'CBC', algorithm => 'Serpent', key_size => 32); + __PACKAGE__->register(CIPHER_UUID_TWOFISH, 'CBC', algorithm => 'Twofish', key_size => 32); + __PACKAGE__->register(CIPHER_UUID_CHACHA20, 'Stream', algorithm => 'ChaCha'); + __PACKAGE__->register(CIPHER_UUID_SALSA20, 'Stream', algorithm => 'Salsa20'); + __PACKAGE__->register(STREAM_ID_CHACHA20, 'Stream', algorithm => 'ChaCha'); + __PACKAGE__->register(STREAM_ID_SALSA20, 'Stream', algorithm => 'Salsa20'); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Cipher - A block cipher mode or cipher stream + +=head1 VERSION + +version 0.800 + +=head1 SYNOPSIS + + use File::KDBX::Cipher; + + my $cipher = File::KDBX::Cipher->new(uuid => $uuid, key => $key, iv => $iv); + + my $ciphertext = $cipher->encrypt('plaintext'); + $ciphertext .= $cipher->encrypt('more plaintext'); + $ciphertext .= $cipher->finish; + + my $plaintext = $cipher->decrypt('ciphertext'); + $plaintext .= $cipher->decrypt('more ciphertext'); + $plaintext .= $cipher->finish; + +=head1 DESCRIPTION + +A cipher is used to encrypt and decrypt KDBX files. The L<File::KDBX> distribution comes with several +pre-registered ciphers ready to go: + +=over 4 + +=item * + +C<61AB05A1-9464-41C3-8D74-3A563DF8DD35> - AES128 (legacy) + +=item * + +C<31C1F2E6-BF71-4350-BE58-05216AFC5AFF> - AES256 + +=item * + +C<D6038A2B-8B6F-4CB5-A524-339A31DBB59A> - ChaCha20 + +=item * + +C<716E1C8A-EE17-4BDC-93AE-A977B882833A> - Salsa20 + +=item * + +C<098563FF-DDF7-4F98-8619-8079F6DB897A> - Serpent + +=item * + +C<AD68F29F-576F-4BB9-A36A-D47AF965346C> - Twofish + +=back + +B<NOTE:> If you want your KDBX file to be readable by other KeePass implementations, you must use a UUID and +algorithm that they support. From the list above, AES256 and ChaCha20 are well-supported. You should avoid +AES128 for new databases. + +You can also L</register> your own cipher. Here is a skeleton: + + package File::KDBX::Cipher::MyCipher; + + use parent 'File::KDBX::Cipher'; + + File::KDBX::Cipher->register( + # $uuid, $package, %args + "\x12\x34\x56\x78\x9a\xbc\xde\xfg\x12\x34\x56\x78\x9a\xbc\xde\xfg" => __PACKAGE__, + ); + + sub init { ... } # optional + + sub encrypt { ... } + sub decrypt { ... } + sub finish { ... } + + sub key_size { ... } + sub iv_size { ... } + sub block_size { ... } + +=head1 ATTRIBUTES + +=head2 uuid + + $uuid = $cipher->uuid; + +Get the UUID if the cipher was constructed with one. + +=head2 stream_id + + $stream_id = $cipher->stream_id; + +Get the stream ID if the cipher was constructed with one. + +=head2 key + + $key = $cipher->key; + +Get the raw encryption key. + +=head2 iv + + $iv = $cipher->iv; + +Get the initialization vector. + +=head2 iv_size + + $size = $cipher->iv_size; + +Get the expected size of the initialization vector, in bytes. + +=head2 key_size + + $size = $cipher->key_size; + +Get the size the mode or stream expects the key to be, in bytes. + +=head2 block_size + + $size = $cipher->block_size; + +Get the block size, in bytes. + +=head2 algorithm + +Get the symmetric cipher algorithm. + +=head1 METHODS + +=head2 new + +=head2 new_from_uuid + +=head2 new_from_stream_id + + $cipher = File::KDBX::Cipher->new(uuid => $uuid, key => $key, iv => $iv); + # OR + $cipher = File::KDBX::Cipher->new_from_uuid($uuid, key => $key, iv => $iv); + + $cipher = File::KDBX::Cipher->new(stream_id => $id, key => $key); + # OR + $cipher = File::KDBX::Cipher->new_from_stream_id($id, key => $key); + +Construct a new L<File::KDBX::Cipher>. + +This is a factory method which returns a subclass. + +=head2 init + + $self->init; + +Initialize the cipher. Called by </new>. + +=head2 encrypt + + $ciphertext = $cipher->encrypt($plaintext, ...); + +Encrypt some data. + +=head2 decrypt + + $plaintext = $cipher->decrypt($ciphertext, ...); + +Decrypt some data. + +=head2 finish + + $ciphertext .= $cipher->finish; # if encrypting + $plaintext .= $cipher->finish; # if decrypting + +Finish the stream. + +=head2 encrypt_finish + + $ciphertext = $cipher->encrypt_finish($plaintext, ...); + +Encrypt and finish a stream in one call. + +=head2 decrypt_finish + + $plaintext = $cipher->decrypt_finish($ciphertext, ...); + +Decrypt and finish a stream in one call. + +=head2 register + + File::KDBX::Cipher->register($uuid => $package, %args); + +Register a cipher. Registered ciphers can be used to encrypt and decrypt KDBX databases. A cipher's UUID +B<must> be unique and B<musn't change>. A cipher UUID is written into each KDBX file and the associated cipher +must be registered with the same UUID in order to decrypt the KDBX file. + +C<$package> should be a Perl package relative to C<File::KDBX::Cipher::> or prefixed with a C<+> if it is +a fully-qualified package. C<%args> are passed as-is to the cipher's L</init> method. + +=head2 unregister + + File::KDBX::Cipher->unregister($uuid); + +Unregister a cipher. Unregistered ciphers can no longer be used to encrypt and decrypt KDBX databases, until +reregistered (see L</register>). + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Cipher/CBC.pm b/lib/File/KDBX/Cipher/CBC.pm new file mode 100644 index 0000000..e1d7cf3 --- /dev/null +++ b/lib/File/KDBX/Cipher/CBC.pm @@ -0,0 +1,98 @@ +package File::KDBX::Cipher::CBC; +# ABSTRACT: A CBC block cipher mode encrypter/decrypter + +use warnings; +use strict; + +use Crypt::Mode::CBC; +use File::KDBX::Error; +use File::KDBX::Util qw(:class); +use namespace::clean; + +extends 'File::KDBX::Cipher'; + +our $VERSION = '0.800'; # VERSION + +has key_size => 32; +sub iv_size { 16 } +sub block_size { 16 } + +sub encrypt { + my $self = shift; + + my $mode = $self->{mode} ||= do { + my $m = Crypt::Mode::CBC->new($self->algorithm); + $m->start_encrypt($self->key, $self->iv); + $m; + }; + + return join('', map { $mode->add(ref $_ ? $$_ : $_) } grep { defined } @_); +} + +sub decrypt { + my $self = shift; + + my $mode = $self->{mode} ||= do { + my $m = Crypt::Mode::CBC->new($self->algorithm); + $m->start_decrypt($self->key, $self->iv); + $m; + }; + + return join('', map { $mode->add(ref $_ ? $$_ : $_) } grep { defined } @_); +} + +sub finish { + my $self = shift; + return '' if !$self->{mode}; + my $out = $self->{mode}->finish; + delete $self->{mode}; + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Cipher::CBC - A CBC block cipher mode encrypter/decrypter + +=head1 VERSION + +version 0.800 + +=head1 SYNOPSIS + + use File::KDBX::Cipher::CBC; + + my $cipher = File::KDBX::Cipher::CBC->new(algorithm => $algo, key => $key, iv => $iv); + +=head1 DESCRIPTION + +A subclass of L<File::KDBX::Cipher> for encrypting and decrypting data using the CBC block cipher mode. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Cipher/Stream.pm b/lib/File/KDBX/Cipher/Stream.pm new file mode 100644 index 0000000..d25a869 --- /dev/null +++ b/lib/File/KDBX/Cipher/Stream.pm @@ -0,0 +1,194 @@ +package File::KDBX::Cipher::Stream; +# ABSTRACT: A cipher stream encrypter/decrypter + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use File::KDBX::Constants qw(:cipher :random_stream); +use File::KDBX::Error; +use File::KDBX::Util qw(:class); +use Scalar::Util qw(blessed); +use Module::Load; +use namespace::clean; + +extends 'File::KDBX::Cipher'; + +our $VERSION = '0.800'; # VERSION + + +has 'counter', is => 'ro', default => 0; +has 'offset', is => 'ro'; +sub key_size { { Salsa20 => 32, ChaCha => 32 }->{$_[0]->{algorithm} || ''} // 0 } +sub iv_size { { Salsa20 => 8, ChaCha => 12 }->{$_[0]->{algorithm} || ''} // -1 } +sub block_size { 1 } + +sub init { + my $self = shift; + my %args = @_; + + if (my $uuid = $args{uuid}) { + if ($uuid eq CIPHER_UUID_CHACHA20 && length($args{iv}) == 16) { + # extract the counter + my $buf = substr($self->{iv}, 0, 4, ''); + $self->{counter} = unpack('L<', $buf); + } + elsif ($uuid eq CIPHER_UUID_SALSA20) { + # only need eight bytes... + $self->{iv} = substr($args{iv}, 8); + } + } + elsif (my $id = $args{stream_id}) { + my $key_ref = ref $args{key} ? $args{key} : \$args{key}; + if ($id == STREAM_ID_CHACHA20) { + ($self->{key}, $self->{iv}) = unpack('a32 a12', digest_data('SHA512', $$key_ref)); + } + elsif ($id == STREAM_ID_SALSA20) { + ($self->{key}, $self->{iv}) = (digest_data('SHA256', $$key_ref), STREAM_SALSA20_IV); + } + } + + return $self; +} + + +sub crypt { + my $self = shift; + my $stream = $self->_stream; + return join('', map { $stream->crypt(ref $_ ? $$_ : $_) } grep { defined } @_); +} + + +sub keystream { + my $self = shift; + return $self->_stream->keystream(@_); +} + + +sub dup { + my $self = shift; + my $class = blessed($self); + + my $dup = bless {%$self, @_}, $class; + delete $dup->{stream}; + return $dup; +} + +sub _stream { + my $self = shift; + + $self->{stream} //= do { + my $s = eval { + my $pkg = 'Crypt::Stream::'.$self->algorithm; + my $counter = $self->counter; + my $pos = 0; + if (defined (my $offset = $self->offset)) { + $counter = int($offset / 64); + $pos = $offset % 64; + } + my $s = $pkg->new($self->key, $self->iv, $counter); + # seek to correct position within block + $s->keystream($pos) if $pos; + $s; + }; + if (my $err = $@) { + throw 'Failed to initialize stream cipher library', + error => $err, + algorithm => $self->{algorithm}, + key_length => length($self->key), + iv_length => length($self->iv), + iv => unpack('H*', $self->iv), + key => unpack('H*', $self->key); + } + $s; + }; +} + +sub encrypt { goto &crypt } +sub decrypt { goto &crypt } + +sub finish { delete $_[0]->{stream}; '' } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Cipher::Stream - A cipher stream encrypter/decrypter + +=head1 VERSION + +version 0.800 + +=head1 SYNOPSIS + + use File::KDBX::Cipher::Stream; + + my $cipher = File::KDBX::Cipher::Stream->new(algorithm => $algorithm, key => $key, iv => $iv); + +=head1 DESCRIPTION + +A subclass of L<File::KDBX::Cipher> for encrypting and decrypting data using a stream cipher. + +=head1 ATTRIBUTES + +=head2 counter + + $counter = $cipher->counter; + +Get the initial counter / block count into the keystream. + +=head2 offset + + $offset = $cipher->offset; + +Get the initial byte offset into the keystream. This has precedence over L</counter> if both are set. + +=head1 METHODS + +=head2 crypt + + $ciphertext = $cipher->crypt($plaintext); + $plaintext = $cipher->crypt($ciphertext); + +Encrypt or decrypt some data. These ciphers are symmetric, so encryption and decryption are the same +operation. This method is an alias for both L<File::KDBX::Cipher/encrypt> and L<File::KDBX::Cipher/decrypt>. + +=head2 keystream + + $stream = $cipher->keystream; + +Access the keystream. + +=head2 dup + + $cipher_copy = $cipher->dup(%attributes); + +Get a copy of an existing cipher with the counter reset, optionally applying new attributes. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Constants.pm b/lib/File/KDBX/Constants.pm new file mode 100644 index 0000000..c109ace --- /dev/null +++ b/lib/File/KDBX/Constants.pm @@ -0,0 +1,1002 @@ +package File::KDBX::Constants; +# ABSTRACT: All the KDBX-related constants you could ever want + +# HOW TO add new constants: +# 1. Add it to the %CONSTANTS structure below. +# 2. List it in the pod at the bottom of this file in the section corresponding to its tag. +# 3. There is no step three. + +use warnings; +use strict; + +use Exporter qw(import); +use Scalar::Util qw(dualvar); +use namespace::clean -except => 'import'; + +our $VERSION = '0.800'; # VERSION + +BEGIN { + my %CONSTANTS = ( + magic => { + __prefix => 'KDBX', + SIG1 => 0x9aa2d903, + SIG1_FIRST_BYTE => 0x03, + SIG2_1 => 0xb54bfb65, + SIG2_2 => 0xb54bfb67, + }, + version => { + __prefix => 'KDBX_VERSION', + _2_0 => 0x00020000, + _3_0 => 0x00030000, + _3_1 => 0x00030001, + _4_0 => 0x00040000, + _4_1 => 0x00040001, + OLDEST => 0x00020000, + LATEST => 0x00040001, + MAJOR_MASK => 0xffff0000, + MINOR_MASK => 0x0000ffff, + }, + header => { + __prefix => 'HEADER', + END => dualvar( 0, 'end'), + COMMENT => dualvar( 1, 'comment'), + CIPHER_ID => dualvar( 2, 'cipher_id'), + COMPRESSION_FLAGS => dualvar( 3, 'compression_flags'), + MASTER_SEED => dualvar( 4, 'master_seed'), + TRANSFORM_SEED => dualvar( 5, 'transform_seed'), + TRANSFORM_ROUNDS => dualvar( 6, 'transform_rounds'), + ENCRYPTION_IV => dualvar( 7, 'encryption_iv'), + INNER_RANDOM_STREAM_KEY => dualvar( 8, 'inner_random_stream_key'), + STREAM_START_BYTES => dualvar( 9, 'stream_start_bytes'), + INNER_RANDOM_STREAM_ID => dualvar( 10, 'inner_random_stream_id'), + KDF_PARAMETERS => dualvar( 11, 'kdf_parameters'), + PUBLIC_CUSTOM_DATA => dualvar( 12, 'public_custom_data'), + }, + compression => { + __prefix => 'COMPRESSION', + NONE => dualvar( 0, 'none'), + GZIP => dualvar( 1, 'gzip'), + }, + cipher => { + __prefix => 'CIPHER', + UUID_AES128 => "\x61\xab\x05\xa1\x94\x64\x41\xc3\x8d\x74\x3a\x56\x3d\xf8\xdd\x35", + UUID_AES256 => "\x31\xc1\xf2\xe6\xbf\x71\x43\x50\xbe\x58\x05\x21\x6a\xfc\x5a\xff", + UUID_CHACHA20 => "\xd6\x03\x8a\x2b\x8b\x6f\x4c\xb5\xa5\x24\x33\x9a\x31\xdb\xb5\x9a", + UUID_SALSA20 => "\x71\x6e\x1c\x8a\xee\x17\x4b\xdc\x93\xae\xa9\x77\xb8\x82\x83\x3a", + UUID_SERPENT => "\x09\x85\x63\xff\xdd\xf7\x4f\x98\x86\x19\x80\x79\xf6\xdb\x89\x7a", + UUID_TWOFISH => "\xad\x68\xf2\x9f\x57\x6f\x4b\xb9\xa3\x6a\xd4\x7a\xf9\x65\x34\x6c", + }, + kdf => { + __prefix => 'KDF', + UUID_AES => "\xc9\xd9\xf3\x9a\x62\x8a\x44\x60\xbf\x74\x0d\x08\xc1\x8a\x4f\xea", + UUID_AES_CHALLENGE_RESPONSE => "\x7c\x02\xbb\x82\x79\xa7\x4a\xc0\x92\x7d\x11\x4a\x00\x64\x82\x38", + UUID_ARGON2D => "\xef\x63\x6d\xdf\x8c\x29\x44\x4b\x91\xf7\xa9\xa4\x03\xe3\x0a\x0c", + UUID_ARGON2ID => "\x9e\x29\x8b\x19\x56\xdb\x47\x73\xb2\x3d\xfc\x3e\xc6\xf0\xa1\xe6", + PARAM_UUID => '$UUID', + PARAM_AES_ROUNDS => 'R', + PARAM_AES_SEED => 'S', + PARAM_ARGON2_SALT => 'S', + PARAM_ARGON2_PARALLELISM => 'P', + PARAM_ARGON2_MEMORY => 'M', + PARAM_ARGON2_ITERATIONS => 'I', + PARAM_ARGON2_VERSION => 'V', + PARAM_ARGON2_SECRET => 'K', + PARAM_ARGON2_ASSOCDATA => 'A', + DEFAULT_AES_ROUNDS => 100_000, + DEFAULT_ARGON2_ITERATIONS => 10, + DEFAULT_ARGON2_MEMORY => 1 << 16, + DEFAULT_ARGON2_PARALLELISM => 2, + DEFAULT_ARGON2_VERSION => 0x13, + }, + random_stream => { + __prefix => 'STREAM', + ID_RC4_VARIANT => 1, + ID_SALSA20 => 2, + ID_CHACHA20 => 3, + SALSA20_IV => "\xe8\x30\x09\x4b\x97\x20\x5d\x2a", + + }, + variant_map => { + __prefix => 'VMAP', + VERSION => 0x0100, + VERSION_MAJOR_MASK => 0xff00, + TYPE_END => 0x00, + TYPE_UINT32 => 0x04, + TYPE_UINT64 => 0x05, + TYPE_BOOL => 0x08, + TYPE_INT32 => 0x0C, + TYPE_INT64 => 0x0D, + TYPE_STRING => 0x18, + TYPE_BYTEARRAY => 0x42, + }, + inner_header => { + __prefix => 'INNER_HEADER', + END => dualvar( 0, 'end'), + INNER_RANDOM_STREAM_ID => dualvar( 1, 'inner_random_stream_id'), + INNER_RANDOM_STREAM_KEY => dualvar( 2, 'inner_random_stream_key'), + BINARY => dualvar( 3, 'binary'), + BINARY_FLAG_PROTECT => 1, + }, + key_file => { + __prefix => 'KEY_FILE', + TYPE_BINARY => dualvar( 1, 'binary'), + TYPE_HASHED => dualvar( 3, 'hashed'), + TYPE_HEX => dualvar( 2, 'hex'), + TYPE_XML => dualvar( 4, 'xml'), + }, + history => { + __prefix => 'HISTORY', + DEFAULT_MAX_AGE => 365, + DEFAULT_MAX_ITEMS => 10, + DEFAULT_MAX_SIZE => 6_291_456, # 6 MiB + }, + iteration => { + ITERATION_BFS => dualvar(1, 'bfs'), + ITERATION_DFS => dualvar(2, 'dfs'), + ITERATION_IDS => dualvar(3, 'ids'), + }, + icon => { + __prefix => 'ICON', + PASSWORD => dualvar( 0, 'Password'), + PACKAGE_NETWORK => dualvar( 1, 'Package_Network'), + MESSAGEBOX_WARNING => dualvar( 2, 'MessageBox_Warning'), + SERVER => dualvar( 3, 'Server'), + KLIPPER => dualvar( 4, 'Klipper'), + EDU_LANGUAGES => dualvar( 5, 'Edu_Languages'), + KCMDF => dualvar( 6, 'KCMDF'), + KATE => dualvar( 7, 'Kate'), + SOCKET => dualvar( 8, 'Socket'), + IDENTITY => dualvar( 9, 'Identity'), + KONTACT => dualvar( 10, 'Kontact'), + CAMERA => dualvar( 11, 'Camera'), + IRKICKFLASH => dualvar( 12, 'IRKickFlash'), + KGPG_KEY3 => dualvar( 13, 'KGPG_Key3'), + LAPTOP_POWER => dualvar( 14, 'Laptop_Power'), + SCANNER => dualvar( 15, 'Scanner'), + MOZILLA_FIREBIRD => dualvar( 16, 'Mozilla_Firebird'), + CDROM_UNMOUNT => dualvar( 17, 'CDROM_Unmount'), + DISPLAY => dualvar( 18, 'Display'), + MAIL_GENERIC => dualvar( 19, 'Mail_Generic'), + MISC => dualvar( 20, 'Misc'), + KORGANIZER => dualvar( 21, 'KOrganizer'), + ASCII => dualvar( 22, 'ASCII'), + ICONS => dualvar( 23, 'Icons'), + CONNECT_ESTABLISHED => dualvar( 24, 'Connect_Established'), + FOLDER_MAIL => dualvar( 25, 'Folder_Mail'), + FILESAVE => dualvar( 26, 'FileSave'), + NFS_UNMOUNT => dualvar( 27, 'NFS_Unmount'), + MESSAGE => dualvar( 28, 'Message'), + KGPG_TERM => dualvar( 29, 'KGPG_Term'), + KONSOLE => dualvar( 30, 'Konsole'), + FILEPRINT => dualvar( 31, 'FilePrint'), + FSVIEW => dualvar( 32, 'FSView'), + RUN => dualvar( 33, 'Run'), + CONFIGURE => dualvar( 34, 'Configure'), + KRFB => dualvar( 35, 'KRFB'), + ARK => dualvar( 36, 'Ark'), + KPERCENTAGE => dualvar( 37, 'KPercentage'), + SAMBA_UNMOUNT => dualvar( 38, 'Samba_Unmount'), + HISTORY => dualvar( 39, 'History'), + MAIL_FIND => dualvar( 40, 'Mail_Find'), + VECTORGFX => dualvar( 41, 'VectorGfx'), + KCMMEMORY => dualvar( 42, 'KCMMemory'), + TRASHCAN_FULL => dualvar( 43, 'Trashcan_Full'), + KNOTES => dualvar( 44, 'KNotes'), + CANCEL => dualvar( 45, 'Cancel'), + HELP => dualvar( 46, 'Help'), + KPACKAGE => dualvar( 47, 'KPackage'), + FOLDER => dualvar( 48, 'Folder'), + FOLDER_BLUE_OPEN => dualvar( 49, 'Folder_Blue_Open'), + FOLDER_TAR => dualvar( 50, 'Folder_Tar'), + DECRYPTED => dualvar( 51, 'Decrypted'), + ENCRYPTED => dualvar( 52, 'Encrypted'), + APPLY => dualvar( 53, 'Apply'), + SIGNATURE => dualvar( 54, 'Signature'), + THUMBNAIL => dualvar( 55, 'Thumbnail'), + KADDRESSBOOK => dualvar( 56, 'KAddressBook'), + VIEW_TEXT => dualvar( 57, 'View_Text'), + KGPG => dualvar( 58, 'KGPG'), + PACKAGE_DEVELOPMENT => dualvar( 59, 'Package_Development'), + KFM_HOME => dualvar( 60, 'KFM_Home'), + SERVICES => dualvar( 61, 'Services'), + TUX => dualvar( 62, 'Tux'), + FEATHER => dualvar( 63, 'Feather'), + APPLE => dualvar( 64, 'Apple'), + W => dualvar( 65, 'W'), + MONEY => dualvar( 66, 'Money'), + CERTIFICATE => dualvar( 67, 'Certificate'), + SMARTPHONE => dualvar( 68, 'Smartphone'), + }, + bool => { + FALSE => !1, + TRUE => 1, + }, + time => { + __prefix => 'TIME', + SECONDS_AD1_TO_UNIX_EPOCH => 62_135_596_800, + }, + yubikey => { + YUBICO_VID => dualvar( 0x1050, 'Yubico'), + YUBIKEY_PID => dualvar( 0x0010, 'YubiKey 1/2'), + NEO_OTP_PID => dualvar( 0x0110, 'YubiKey NEO OTP'), + NEO_OTP_CCID_PID => dualvar( 0x0111, 'YubiKey NEO OTP+CCID'), + NEO_CCID_PID => dualvar( 0x0112, 'YubiKey NEO CCID'), + NEO_U2F_PID => dualvar( 0x0113, 'YubiKey NEO FIDO'), + NEO_OTP_U2F_PID => dualvar( 0x0114, 'YubiKey NEO OTP+FIDO'), + NEO_U2F_CCID_PID => dualvar( 0x0115, 'YubiKey NEO FIDO+CCID'), + NEO_OTP_U2F_CCID_PID => dualvar( 0x0116, 'YubiKey NEO OTP+FIDO+CCID'), + YK4_OTP_PID => dualvar( 0x0401, 'YubiKey 4/5 OTP'), + YK4_U2F_PID => dualvar( 0x0402, 'YubiKey 4/5 FIDO'), + YK4_OTP_U2F_PID => dualvar( 0x0403, 'YubiKey 4/5 OTP+FIDO'), + YK4_CCID_PID => dualvar( 0x0404, 'YubiKey 4/5 CCID'), + YK4_OTP_CCID_PID => dualvar( 0x0405, 'YubiKey 4/5 OTP+CCID'), + YK4_U2F_CCID_PID => dualvar( 0x0406, 'YubiKey 4/5 FIDO+CCID'), + YK4_OTP_U2F_CCID_PID => dualvar( 0x0407, 'YubiKey 4/5 OTP+FIDO+CCID'), + PLUS_U2F_OTP_PID => dualvar( 0x0410, 'YubiKey Plus OTP+FIDO'), + + ONLYKEY_VID => dualvar( 0x1d50, 'OnlyKey'), + ONLYKEY_PID => dualvar( 0x60fc, 'OnlyKey'), + + YK_EUSBERR => dualvar( 0x01, 'USB error'), + YK_EWRONGSIZ => dualvar( 0x02, 'wrong size'), + YK_EWRITEERR => dualvar( 0x03, 'write error'), + YK_ETIMEOUT => dualvar( 0x04, 'timeout'), + YK_ENOKEY => dualvar( 0x05, 'no yubikey present'), + YK_EFIRMWARE => dualvar( 0x06, 'unsupported firmware version'), + YK_ENOMEM => dualvar( 0x07, 'out of memory'), + YK_ENOSTATUS => dualvar( 0x08, 'no status structure given'), + YK_ENOTYETIMPL => dualvar( 0x09, 'not yet implemented'), + YK_ECHECKSUM => dualvar( 0x0a, 'checksum mismatch'), + YK_EWOULDBLOCK => dualvar( 0x0b, 'operation would block'), + YK_EINVALIDCMD => dualvar( 0x0c, 'invalid command for operation'), + YK_EMORETHANONE => dualvar( 0x0d, 'expected only one YubiKey but serveral present'), + YK_ENODATA => dualvar( 0x0e, 'no data returned from device'), + + CONFIG1_VALID => 0x01, + CONFIG2_VALID => 0x02, + CONFIG1_TOUCH => 0x04, + CONFIG2_TOUCH => 0x08, + CONFIG_LED_INV => 0x10, + CONFIG_STATUS_MASK => 0x1f, + }, + ); + + our %EXPORT_TAGS; + my %seen; + no strict 'refs'; ## no critic (ProhibitNoStrict) + while (my ($tag, $constants) = each %CONSTANTS) { + my $prefix = delete $constants->{__prefix}; + while (my ($name, $value) = each %$constants) { + my $val = $value; + $val = $val+0 if $tag eq 'icon'; # TODO + $name =~ s/^_+//; + my $full_name = $prefix ? "${prefix}_${name}" : $name; + die "Duplicate constant: $full_name\n" if $seen{$full_name}; + *{$full_name} = sub() { $value }; + push @{$EXPORT_TAGS{$tag} //= []}, $full_name; + $seen{$full_name}++; + } + } +} + +our %EXPORT_TAGS; +push @{$EXPORT_TAGS{header}}, 'to_header_constant'; +push @{$EXPORT_TAGS{compression}}, 'to_compression_constant'; +push @{$EXPORT_TAGS{inner_header}}, 'to_inner_header_constant'; +push @{$EXPORT_TAGS{icon}}, 'to_icon_constant'; + +$EXPORT_TAGS{all} = [map { @$_ } values %EXPORT_TAGS]; +our @EXPORT_OK = sort @{$EXPORT_TAGS{all}}; + +my %HEADER; +for my $header ( + HEADER_END, HEADER_COMMENT, HEADER_CIPHER_ID, HEADER_COMPRESSION_FLAGS, + HEADER_MASTER_SEED, HEADER_TRANSFORM_SEED, HEADER_TRANSFORM_ROUNDS, + HEADER_ENCRYPTION_IV, HEADER_INNER_RANDOM_STREAM_KEY, HEADER_STREAM_START_BYTES, + HEADER_INNER_RANDOM_STREAM_ID, HEADER_KDF_PARAMETERS, HEADER_PUBLIC_CUSTOM_DATA, +) { + $HEADER{$header} = $HEADER{0+$header} = $header; +} +sub to_header_constant { $HEADER{$_[0] // ''} } + +my %COMPRESSION; +for my $compression (COMPRESSION_NONE, COMPRESSION_GZIP) { + $COMPRESSION{$compression} = $COMPRESSION{0+$compression} = $compression; +} +sub to_compression_constant { $COMPRESSION{$_[0] // ''} } + +my %INNER_HEADER; +for my $inner_header ( + INNER_HEADER_END, INNER_HEADER_INNER_RANDOM_STREAM_ID, + INNER_HEADER_INNER_RANDOM_STREAM_KEY, INNER_HEADER_BINARY, +) { + $INNER_HEADER{$inner_header} = $INNER_HEADER{0+$inner_header} = $inner_header; +} +sub to_inner_header_constant { $INNER_HEADER{$_[0] // ''} } + +my %ICON; +for my $icon ( + ICON_PASSWORD, ICON_PACKAGE_NETWORK, ICON_MESSAGEBOX_WARNING, ICON_SERVER, ICON_KLIPPER, + ICON_EDU_LANGUAGES, ICON_KCMDF, ICON_KATE, ICON_SOCKET, ICON_IDENTITY, ICON_KONTACT, ICON_CAMERA, + ICON_IRKICKFLASH, ICON_KGPG_KEY3, ICON_LAPTOP_POWER, ICON_SCANNER, ICON_MOZILLA_FIREBIRD, + ICON_CDROM_UNMOUNT, ICON_DISPLAY, ICON_MAIL_GENERIC, ICON_MISC, ICON_KORGANIZER, ICON_ASCII, ICON_ICONS, + ICON_CONNECT_ESTABLISHED, ICON_FOLDER_MAIL, ICON_FILESAVE, ICON_NFS_UNMOUNT, ICON_MESSAGE, ICON_KGPG_TERM, + ICON_KONSOLE, ICON_FILEPRINT, ICON_FSVIEW, ICON_RUN, ICON_CONFIGURE, ICON_KRFB, ICON_ARK, + ICON_KPERCENTAGE, ICON_SAMBA_UNMOUNT, ICON_HISTORY, ICON_MAIL_FIND, ICON_VECTORGFX, ICON_KCMMEMORY, + ICON_TRASHCAN_FULL, ICON_KNOTES, ICON_CANCEL, ICON_HELP, ICON_KPACKAGE, ICON_FOLDER, + ICON_FOLDER_BLUE_OPEN, ICON_FOLDER_TAR, ICON_DECRYPTED, ICON_ENCRYPTED, ICON_APPLY, ICON_SIGNATURE, + ICON_THUMBNAIL, ICON_KADDRESSBOOK, ICON_VIEW_TEXT, ICON_KGPG, ICON_PACKAGE_DEVELOPMENT, ICON_KFM_HOME, + ICON_SERVICES, ICON_TUX, ICON_FEATHER, ICON_APPLE, ICON_W, ICON_MONEY, ICON_CERTIFICATE, ICON_SMARTPHONE, +) { + $ICON{$icon} = $ICON{0+$icon} = $icon; +} +sub to_icon_constant { $ICON{$_[0] // ''} // ICON_PASSWORD } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Constants - All the KDBX-related constants you could ever want + +=head1 VERSION + +version 0.800 + +=head1 SYNOPSIS + + use File::KDBX::Constants qw(:all); + + say KDBX_VERSION_4_1; + +=head1 DESCRIPTION + +This module provides importable constants related to KDBX. Constants can be imported individually or in groups +(by tag). The available tags are: + +=over 4 + +=item * + +L</:magic> + +=item * + +L</:version> + +=item * + +L</:header> + +=item * + +L</:compression> + +=item * + +L</:cipher> + +=item * + +L</:random_stream> + +=item * + +L</:kdf> + +=item * + +L</:variant_map> + +=item * + +L</:inner_header> + +=item * + +L</:key_file> + +=item * + +L</:history> + +=item * + +L</:icon> + +=item * + +L</:bool> + +=item * + +L</:time> + +=item * + +L</:yubikey> + +=item * + +C<:all> - All of the above + +=back + +View the source of this module to see the constant values (but really you shouldn't care). + +=head1 FUNCTIONS + +=head2 to_header_constant + + $constant = to_header_constant($number); + $constant = to_header_constant($string); + +Get a header constant from an integer or string value. + +=head2 to_compression_constant + + $constant = to_compression_constant($number); + $constant = to_compression_constant($string); + +Get a compression constant from an integer or string value. + +=head2 to_inner_header_constant + + $constant = to_inner_header_constant($number); + $constant = to_inner_header_constant($string); + +Get an inner header constant from an integer or string value. + +=head2 to_icon_constant + + $constant = to_icon_constant($number); + $constant = to_icon_constant($string); + +Get an icon constant from an integer or string value. + +=head1 CONSTANTS + +=head2 :magic + +Constants related to identifying the file types: + +=over 4 + +=item C<KDBX_SIG1> + +=item C<KDBX_SIG1_FIRST_BYTE> + +=item C<KDBX_SIG2_1> + +=item C<KDBX_SIG2_2> + +=back + +=head2 :version + +Constants related to identifying the format version of a file: + +=over 4 + +=item C<KDBX_VERSION_2_0> + +=item C<KDBX_VERSION_3_0> + +=item C<KDBX_VERSION_3_1> + +=item C<KDBX_VERSION_4_0> + +=item C<KDBX_VERSION_4_1> + +=item C<KDBX_VERSION_OLDEST> + +=item C<KDBX_VERSION_LATEST> + +=item C<KDBX_VERSION_MAJOR_MASK> + +=item C<KDBX_VERSION_MINOR_MASK> + +=back + +=head2 :header + +Constants related to parsing and generating KDBX file headers: + +=over 4 + +=item C<HEADER_END> + +=item C<HEADER_COMMENT> + +=item C<HEADER_CIPHER_ID> + +=item C<HEADER_COMPRESSION_FLAGS> + +=item C<HEADER_MASTER_SEED> + +=item C<HEADER_TRANSFORM_SEED> + +=item C<HEADER_TRANSFORM_ROUNDS> + +=item C<HEADER_ENCRYPTION_IV> + +=item C<HEADER_INNER_RANDOM_STREAM_KEY> + +=item C<HEADER_STREAM_START_BYTES> + +=item C<HEADER_INNER_RANDOM_STREAM_ID> + +=item C<HEADER_KDF_PARAMETERS> + +=item C<HEADER_PUBLIC_CUSTOM_DATA> + +=back + +=head2 :compression + +Constants related to identifying the compression state of a file: + +=over 4 + +=item C<COMPRESSION_NONE> + +=item C<COMPRESSION_GZIP> + +=back + +=head2 :cipher + +Constants related ciphers: + +=over 4 + +=item C<CIPHER_UUID_AES128> + +=item C<CIPHER_UUID_AES256> + +=item C<CIPHER_UUID_CHACHA20> + +=item C<CIPHER_UUID_SALSA20> + +=item C<CIPHER_UUID_SERPENT> + +=item C<CIPHER_UUID_TWOFISH> + +=back + +=head2 :random_stream + +Constants related to memory protection stream ciphers: + +=over 4 + +=item C<STREAM_ID_RC4_VARIANT> + +This is insecure and not implemented. + +=item C<STREAM_ID_SALSA20> + +=item C<STREAM_ID_CHACHA20> + +=item C<STREAM_SALSA20_IV> + +=back + +=head2 :kdf + +Constants related to key derivation functions and configuration: + +=over 4 + +=item C<KDF_UUID_AES> + +=item C<KDF_UUID_AES_CHALLENGE_RESPONSE> + +This is what KeePassXC calls C<KDF_AES_KDBX4>. + +=item C<KDF_UUID_ARGON2D> + +=item C<KDF_UUID_ARGON2ID> + +=item C<KDF_PARAM_UUID> + +=item C<KDF_PARAM_AES_ROUNDS> + +=item C<KDF_PARAM_AES_SEED> + +=item C<KDF_PARAM_ARGON2_SALT> + +=item C<KDF_PARAM_ARGON2_PARALLELISM> + +=item C<KDF_PARAM_ARGON2_MEMORY> + +=item C<KDF_PARAM_ARGON2_ITERATIONS> + +=item C<KDF_PARAM_ARGON2_VERSION> + +=item C<KDF_PARAM_ARGON2_SECRET> + +=item C<KDF_PARAM_ARGON2_ASSOCDATA> + +=item C<KDF_DEFAULT_AES_ROUNDS> + +=item C<KDF_DEFAULT_ARGON2_ITERATIONS> + +=item C<KDF_DEFAULT_ARGON2_MEMORY> + +=item C<KDF_DEFAULT_ARGON2_PARALLELISM> + +=item C<KDF_DEFAULT_ARGON2_VERSION> + +=back + +=head2 :variant_map + +Constants related to parsing and generating KDBX4 variant maps: + +=over 4 + +=item C<VMAP_VERSION> + +=item C<VMAP_VERSION_MAJOR_MASK> + +=item C<VMAP_TYPE_END> + +=item C<VMAP_TYPE_UINT32> + +=item C<VMAP_TYPE_UINT64> + +=item C<VMAP_TYPE_BOOL> + +=item C<VMAP_TYPE_INT32> + +=item C<VMAP_TYPE_INT64> + +=item C<VMAP_TYPE_STRING> + +=item C<VMAP_TYPE_BYTEARRAY> + +=back + +=head2 :inner_header + +Constants related to parsing and generating KDBX4 inner headers: + +=over 4 + +=item C<INNER_HEADER_END> + +=item C<INNER_HEADER_INNER_RANDOM_STREAM_ID> + +=item C<INNER_HEADER_INNER_RANDOM_STREAM_KEY> + +=item C<INNER_HEADER_BINARY> + +=item C<INNER_HEADER_BINARY_FLAG_PROTECT> + +=back + +=head2 :key_file + +Constants related to identifying key file types: + +=over 4 + +=item C<KEY_FILE_TYPE_BINARY> + +=item C<KEY_FILE_TYPE_HASHED> + +=item C<KEY_FILE_TYPE_HEX> + +=item C<KEY_FILE_TYPE_XML> + +=back + +=head2 :history + +Constants for history-related default values: + +=over 4 + +=item C<HISTORY_DEFAULT_MAX_AGE> + +=item C<HISTORY_DEFAULT_MAX_ITEMS> + +=item C<HISTORY_DEFAULT_MAX_SIZE> + +=back + +=head2 :iteration + +Constants for searching algorithms. + +=over 4 + +=item C<ITERATION_IDS> - Iterative deepening search + +=item C<ITERATION_BFS> - Breadth-first search + +=item C<ITERATION_DFS> - Depth-first search + +=back + +=head2 :icon + +Constants for default icons used by KeePass password safe implementations: + +=over 4 + +=item C<ICON_PASSWORD> + +=item C<ICON_PACKAGE_NETWORK> + +=item C<ICON_MESSAGEBOX_WARNING> + +=item C<ICON_SERVER> + +=item C<ICON_KLIPPER> + +=item C<ICON_EDU_LANGUAGES> + +=item C<ICON_KCMDF> + +=item C<ICON_KATE> + +=item C<ICON_SOCKET> + +=item C<ICON_IDENTITY> + +=item C<ICON_KONTACT> + +=item C<ICON_CAMERA> + +=item C<ICON_IRKICKFLASH> + +=item C<ICON_KGPG_KEY3> + +=item C<ICON_LAPTOP_POWER> + +=item C<ICON_SCANNER> + +=item C<ICON_MOZILLA_FIREBIRD> + +=item C<ICON_CDROM_UNMOUNT> + +=item C<ICON_DISPLAY> + +=item C<ICON_MAIL_GENERIC> + +=item C<ICON_MISC> + +=item C<ICON_KORGANIZER> + +=item C<ICON_ASCII> + +=item C<ICON_ICONS> + +=item C<ICON_CONNECT_ESTABLISHED> + +=item C<ICON_FOLDER_MAIL> + +=item C<ICON_FILESAVE> + +=item C<ICON_NFS_UNMOUNT> + +=item C<ICON_MESSAGE> + +=item C<ICON_KGPG_TERM> + +=item C<ICON_KONSOLE> + +=item C<ICON_FILEPRINT> + +=item C<ICON_FSVIEW> + +=item C<ICON_RUN> + +=item C<ICON_CONFIGURE> + +=item C<ICON_KRFB> + +=item C<ICON_ARK> + +=item C<ICON_KPERCENTAGE> + +=item C<ICON_SAMBA_UNMOUNT> + +=item C<ICON_HISTORY> + +=item C<ICON_MAIL_FIND> + +=item C<ICON_VECTORGFX> + +=item C<ICON_KCMMEMORY> + +=item C<ICON_TRASHCAN_FULL> + +=item C<ICON_KNOTES> + +=item C<ICON_CANCEL> + +=item C<ICON_HELP> + +=item C<ICON_KPACKAGE> + +=item C<ICON_FOLDER> + +=item C<ICON_FOLDER_BLUE_OPEN> + +=item C<ICON_FOLDER_TAR> + +=item C<ICON_DECRYPTED> + +=item C<ICON_ENCRYPTED> + +=item C<ICON_APPLY> + +=item C<ICON_SIGNATURE> + +=item C<ICON_THUMBNAIL> + +=item C<ICON_KADDRESSBOOK> + +=item C<ICON_VIEW_TEXT> + +=item C<ICON_KGPG> + +=item C<ICON_PACKAGE_DEVELOPMENT> + +=item C<ICON_KFM_HOME> + +=item C<ICON_SERVICES> + +=item C<ICON_TUX> + +=item C<ICON_FEATHER> + +=item C<ICON_APPLE> + +=item C<ICON_W> + +=item C<ICON_MONEY> + +=item C<ICON_CERTIFICATE> + +=item C<ICON_SMARTPHONE> + +=back + +=head2 :bool + +Boolean values: + +=over 4 + +=item C<FALSE> + +=item C<TRUE> + +=back + +=head2 :time + +Constants related to time: + +=over 4 + +=item C<TIME_SECONDS_AD1_TO_UNIX_EPOCH> + +=back + +=head2 :yubikey + +Constants related to working with YubiKeys: + +=over 4 + +=item C<YUBICO_VID> + +=item C<YUBIKEY_PID> + +=item C<NEO_OTP_PID> + +=item C<NEO_OTP_CCID_PID> + +=item C<NEO_CCID_PID> + +=item C<NEO_U2F_PID> + +=item C<NEO_OTP_U2F_PID> + +=item C<NEO_U2F_CCID_PID> + +=item C<NEO_OTP_U2F_CCID_PID> + +=item C<YK4_OTP_PID> + +=item C<YK4_U2F_PID> + +=item C<YK4_OTP_U2F_PID> + +=item C<YK4_CCID_PID> + +=item C<YK4_OTP_CCID_PID> + +=item C<YK4_U2F_CCID_PID> + +=item C<YK4_OTP_U2F_CCID_PID> + +=item C<PLUS_U2F_OTP_PID> + +=item C<ONLYKEY_VID> + +=item C<ONLYKEY_PID> + +=item C<YK_EUSBERR> + +=item C<YK_EWRONGSIZ> + +=item C<YK_EWRITEERR> + +=item C<YK_ETIMEOUT> + +=item C<YK_ENOKEY> + +=item C<YK_EFIRMWARE> + +=item C<YK_ENOMEM> + +=item C<YK_ENOSTATUS> + +=item C<YK_ENOTYETIMPL> + +=item C<YK_ECHECKSUM> + +=item C<YK_EWOULDBLOCK> + +=item C<YK_EINVALIDCMD> + +=item C<YK_EMORETHANONE> + +=item C<YK_ENODATA> + +=item C<CONFIG1_VALID> + +=item C<CONFIG2_VALID> + +=item C<CONFIG1_TOUCH> + +=item C<CONFIG2_TOUCH> + +=item C<CONFIG_LED_INV> + +=item C<CONFIG_STATUS_MASK> + +=back + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Dumper.pm b/lib/File/KDBX/Dumper.pm new file mode 100644 index 0000000..db13dd4 --- /dev/null +++ b/lib/File/KDBX/Dumper.pm @@ -0,0 +1,442 @@ +package File::KDBX::Dumper; +# ABSTRACT: Write KDBX files + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use File::KDBX::Constants qw(:magic :header :version :random_stream); +use File::KDBX::Error; +use File::KDBX::Util qw(:class); +use File::KDBX; +use IO::Handle; +use Module::Load; +use Ref::Util qw(is_ref is_scalarref); +use Scalar::Util qw(looks_like_number openhandle); +use namespace::clean; + +our $VERSION = '0.800'; # VERSION + + +sub new { + my $class = shift; + my $self = bless {}, $class; + $self->init(@_); +} + + +sub init { + my $self = shift; + my %args = @_; + + @$self{keys %args} = values %args; + + return $self; +} + +sub _rebless { + my $self = shift; + my $format = shift // $self->format; + + my $version = $self->kdbx->version; + + my $subclass; + + if (defined $format) { + $subclass = $format; + } + elsif (!defined $version) { + $subclass = 'XML'; + } + elsif ($self->kdbx->sig2 == KDBX_SIG2_1) { + $subclass = 'KDB'; + } + elsif (looks_like_number($version)) { + my $major = $version & KDBX_VERSION_MAJOR_MASK; + my %subclasses = ( + KDBX_VERSION_2_0() => 'V3', + KDBX_VERSION_3_0() => 'V3', + KDBX_VERSION_4_0() => 'V4', + ); + if ($major == KDBX_VERSION_2_0) { + alert sprintf("Upgrading KDBX version %x to version %x\n", $version, KDBX_VERSION_3_1); + $self->kdbx->version(KDBX_VERSION_3_1); + } + $subclass = $subclasses{$major} + or throw sprintf('Unsupported KDBX file version: %x', $version), version => $version; + } + else { + throw sprintf('Unknown file version: %s', $version), version => $version; + } + + load "File::KDBX::Dumper::$subclass"; + bless $self, "File::KDBX::Dumper::$subclass"; +} + + +sub reset { + my $self = shift; + %$self = (); + return $self; +} + + +sub dump { + my $self = shift; + my $dst = shift; + return $self->dump_handle($dst, @_) if openhandle($dst); + return $self->dump_string($dst, @_) if is_scalarref($dst); + return $self->dump_file($dst, @_) if defined $dst && !is_ref($dst); + throw 'Programmer error: Must pass a stringref, filepath or IO handle to dump'; +} + + +sub dump_string { + my $self = shift; + my $ref = is_scalarref($_[0]) ? shift : undef; + my %args = @_ % 2 == 0 ? @_ : (key => shift, @_); + + my $key = delete $args{key}; + $args{kdbx} //= $self->kdbx; + + $ref //= do { + my $buf = ''; + \$buf; + }; + + open(my $fh, '>', $ref) or throw "Failed to open string buffer: $!"; + + $self = $self->new if !ref $self; + $self->init(%args, fh => $fh)->_dump($fh, $key); + + return $ref; +} + + +sub dump_file { + my $self = shift; + my $filepath = shift; + my %args = @_ % 2 == 0 ? @_ : (key => shift, @_); + + my $key = delete $args{key}; + $args{kdbx} //= $self->kdbx; + + require File::Temp; + my ($fh, $filepath_temp) = eval { File::Temp::tempfile("${filepath}-XXXXXX", CLEANUP => 1) }; + if (!$fh or my $err = $@) { + $err //= 'Unknown error'; + throw sprintf('Open file failed (%s): %s', $filepath_temp, $err), + error => $err, + filepath => $filepath_temp; + } + $fh->autoflush(1); + + $self = $self->new if !ref $self; + $self->init(%args, fh => $fh, filepath => $filepath); + $self->_dump($fh, $key); + close($fh); + + my ($file_mode, $file_uid, $file_gid) = (stat($filepath))[2, 4, 5]; + + my $mode = $args{mode} // $file_mode // do { my $m = umask; defined $m ? oct(666) &~ $m : undef }; + my $uid = $args{uid} // $file_uid // -1; + my $gid = $args{gid} // $file_gid // -1; + chmod($mode, $filepath_temp) if defined $mode; + chown($uid, $gid, $filepath_temp); + rename($filepath_temp, $filepath) or throw "Failed to write file ($filepath): $!", filepath => $filepath; + + return $self; +} + + +sub dump_handle { + my $self = shift; + my $fh = shift; + my %args = @_ % 2 == 0 ? @_ : (key => shift, @_); + + $fh = *STDOUT if $fh eq '-'; + + my $key = delete $args{key}; + $args{kdbx} //= $self->kdbx; + + $self = $self->new if !ref $self; + $self->init(%args, fh => $fh)->_dump($fh, $key); +} + + +sub kdbx { + my $self = shift; + return File::KDBX->new if !ref $self; + $self->{kdbx} = shift if @_; + $self->{kdbx} //= File::KDBX->new; +} + + +has 'format', is => 'ro'; +has 'inner_format', is => 'ro', default => 'XML'; +has 'allow_upgrade', is => 'ro', default => 1; +has 'randomize_seeds', is => 'ro', default => 1; + + +sub min_version { KDBX_VERSION_OLDEST } + +sub _fh { $_[0]->{fh} or throw 'IO handle not set' } + +sub _dump { + my $self = shift; + my $fh = shift; + my $key = shift; + + my $kdbx = $self->kdbx; + + my $min_version = $kdbx->minimum_version; + if ($kdbx->version < $min_version && $self->allow_upgrade) { + alert sprintf("Implicitly upgrading database from %x to %x\n", $kdbx->version, $min_version), + version => $kdbx->version, min_version => $min_version; + $kdbx->version($min_version); + } + $self->_rebless; + + if (ref($self) =~ /::(?:KDB|V[34])$/) { + $key //= $kdbx->key ? $kdbx->key->reload : undef; + defined $key or throw 'Must provide a master key', type => 'key.missing'; + } + + $self->_prepare; + + my $magic = $self->_write_magic_numbers($fh); + my $headers = $self->_write_headers($fh); + + $kdbx->unlock; + + $self->_write_body($fh, $key, "$magic$headers"); + + return $kdbx; +} + +sub _prepare { + my $self = shift; + my $kdbx = $self->kdbx; + + if ($kdbx->version < KDBX_VERSION_4_0) { + # force Salsa20 inner random stream + $kdbx->inner_random_stream_id(STREAM_ID_SALSA20); + my $key = $kdbx->inner_random_stream_key; + substr($key, 32) = ''; + $kdbx->inner_random_stream_key($key); + } + + $kdbx->randomize_seeds if $self->randomize_seeds; +} + +sub _write_magic_numbers { + my $self = shift; + my $fh = shift; + + my $kdbx = $self->kdbx; + + $kdbx->sig1 == KDBX_SIG1 or throw 'Invalid file signature', sig1 => $kdbx->sig1; + $kdbx->version < $self->min_version || KDBX_VERSION_LATEST < $kdbx->version + and throw 'Unsupported file version', version => $kdbx->version; + + my @magic = ($kdbx->sig1, $kdbx->sig2, $kdbx->version); + + my $buf = pack('L<3', @magic); + $fh->print($buf) or throw 'Failed to write file signature'; + + return $buf; +} + +sub _write_headers { die "Not implemented" } + +sub _write_body { die "Not implemented" } + +sub _write_inner_body { + my $self = shift; + + my $current_pkg = ref $self; + require Scope::Guard; + my $guard = Scope::Guard->new(sub { bless $self, $current_pkg }); + + $self->_rebless($self->inner_format); + $self->_write_inner_body(@_); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Dumper - Write KDBX files + +=head1 VERSION + +version 0.800 + +=head1 ATTRIBUTES + +=head2 kdbx + + $kdbx = $dumper->kdbx; + $dumper->kdbx($kdbx); + +Get or set the L<File::KDBX> instance with the data to be dumped. + +=head2 format + +Get the file format used for writing the database. Normally the format is auto-detected from the database, +which is the safest choice. Possible formats: + +=over 4 + +=item * + +C<V3> + +=item * + +C<V4> + +=item * + +C<KDB> + +=item * + +C<XML> (only used if explicitly set) + +=item * + +C<Raw> (only used if explicitly set) + +=back + +B<WARNING:> There is a potential for data loss if you explicitly use a format that doesn't support the +features used by the KDBX database being written. + +The most common reason to explicitly specify the file format is to save a database as an unencrypted XML file: + + $kdbx->dump_file('database.xml', format => 'XML'); + +=head2 inner_format + +Get the format of the data inside the KDBX envelope. This only applies to C<V3> and C<V4> formats. Possible +formats: + +=over 4 + +=item * + +C<XML> - Write the database groups and entries as XML (default) + +=item * + +C<Raw> - Write L<File::KDBX/raw> instead of the actual database contents + +=back + +=head2 allow_upgrade + + $bool = $dumper->allow_upgrade; + +Whether or not to allow implicitly upgrading a database to a newer version. When enabled, in order to avoid +potential data loss, the database can be upgraded as-needed in cases where the database file format version is +too low to support new features being used. + +The default is to allow upgrading. + +=head2 randomize_seeds + + $bool = $dumper->randomize_seeds; + +Whether or not to randomize seeds in a database before writing. The default is to randomize seeds, and there's +not often a good reason not to do so. If disabled, the seeds associated with the KDBX database will be used as +they are. + +=head1 METHODS + +=head2 new + + $dumper = File::KDBX::Dumper->new(%attributes); + +Construct a new L<File::KDBX::Dumper>. + +=head2 init + + $dumper = $dumper->init(%attributes); + +Initialize a L<File::KDBX::Dumper> with a new set of attributes. + +This is called by L</new>. + +=head2 reset + + $dumper = $dumper->reset; + +Set a L<File::KDBX::Dumper> to a blank state, ready to dumper another KDBX file. + +=head2 dump + + $dumper->dump(\$string, $key); + $dumper->dump(*IO, $key); + $dumper->dump($filepath, $key); + +Dump a KDBX file. + +The C<$key> is either a L<File::KDBX::Key> or a primitive that can be converted to a Key object. + +=head2 dump_string + + $dumper->dump_string(\$string, $key); + \$string = $dumper->dump_string($key); + +Dump a KDBX file to a string / memory buffer. + +=head2 dump_file + + $dumper->dump_file($filepath, $key); + +Dump a KDBX file to a filesystem. + +=head2 dump_handle + + $dumper->dump_handle($fh, $key); + $dumper->dump_handle(*IO, $key); + +Dump a KDBX file to an input stream / file handle. + +=head2 min_version + + $min_version = File::KDBX::Dumper->min_version; + +Get the minimum KDBX file version supported, which is 3.0 or C<0x00030000> as +it is encoded. + +To generate older KDBX files unsupported by this module, try L<File::KeePass>. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Dumper/KDB.pm b/lib/File/KDBX/Dumper/KDB.pm new file mode 100644 index 0000000..0350a39 --- /dev/null +++ b/lib/File/KDBX/Dumper/KDB.pm @@ -0,0 +1,179 @@ +package File::KDBX::Dumper::KDB; +# ABSTRACT: Write KDB files + +use warnings; +use strict; + +use Crypt::PRNG qw(irand); +use Encode qw(encode); +use File::KDBX::Constants qw(:magic); +use File::KDBX::Error; +use File::KDBX::Loader::KDB; +use File::KDBX::Util qw(:class :uuid load_optional); +use namespace::clean; + +extends 'File::KDBX::Dumper'; + +our $VERSION = '0.800'; # VERSION + +sub _write_magic_numbers { '' } +sub _write_headers { '' } + +sub _write_body { + my $self = shift; + my $fh = shift; + my $key = shift; + + load_optional(qw{File::KeePass File::KeePass::KDBX}); + + my $k = File::KeePass::KDBX->new($self->kdbx)->to_fkp; + $self->_write_custom_icons($self->kdbx, $k); + + # TODO create a KPX_CUSTOM_ICONS_4 meta stream. FKP itself handles KPX_GROUP_TREE_STATE + + substr($k->header->{seed_rand}, 16) = ''; + + $key = $self->kdbx->composite_key($key, keep_primitive => 1); + + my $dump = eval { $k->gen_db(File::KDBX::Loader::KDB::_convert_kdbx_to_keepass_master_key($key)) }; + if (my $err = $@) { + throw 'Failed to generate KDB file', error => $err; + } + + $self->kdbx->key($key); + + print $fh $dump; +} + +sub _write_custom_icons { + my $self = shift; + my $kdbx = shift; + my $k = shift; + + return if $kdbx->sig2 != KDBX_SIG2_1; + return if $k->find_entries({ + title => 'Meta-Info', + username => 'SYSTEM', + url => '$', + comment => 'KPX_CUSTOM_ICONS_4', + }); + + my @icons; # icon data + my %icons; # icon uuid -> index + my %entries; # id -> index + my %groups; # id -> index + my %gid; + + for my $icon (@{$kdbx->custom_icons}) { + my $uuid = $icon->{uuid}; + my $data = $icon->{data} or next; + push @icons, $data; + $icons{$uuid} = $#icons; + } + for my $entry ($k->find_entries({})) { + my $icon_uuid = $entry->{custom_icon_uuid} // next; + my $icon_index = $icons{$icon_uuid} // next; + + $entry->{id} //= generate_uuid; + next if $entries{$entry->{id}}; + + $entries{$entry->{id}} = $icon_index; + } + for my $group ($k->find_groups({})) { + $gid{$group->{id} || ''}++; + my $icon_uuid = $group->{custom_icon_uuid} // next; + my $icon_index = $icons{$icon_uuid} // next; + + if ($group->{id} =~ /^[A-Fa-f0-9]{16}$/) { + $group->{id} = hex($group->{id}); + } + elsif ($group->{id} !~ /^\d+$/) { + do { + $group->{id} = irand; + } while $gid{$group->{id}}; + } + $gid{$group->{id}}++; + next if $groups{$group->{id}}; + + $groups{$group->{id}} = $icon_index; + } + + return if !@icons; + + my $stream = ''; + $stream .= pack('L<3', scalar @icons, scalar keys %entries, scalar keys %groups); + for (my $i = 0; $i < @icons; ++$i) { + $stream .= pack('L<', length($icons[$i])); + $stream .= $icons[$i]; + } + while (my ($id, $icon_index) = each %entries) { + $stream .= pack('a16 L<', $id, $icon_index); + } + while (my ($id, $icon_index) = each %groups) { + $stream .= pack('L<2', $id, $icon_index); + } + + $k->add_entry({ + comment => 'KPX_CUSTOM_ICONS_4', + title => 'Meta-Info', + username => 'SYSTEM', + url => '$', + id => '0' x 16, + icon => 0, + binary => {'bin-stream' => $stream}, + }); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Dumper::KDB - Write KDB files + +=head1 VERSION + +version 0.800 + +=head1 DESCRIPTION + +Dump older KDB (KeePass 1) files. This feature requires additional modules to be installed: + +=over 4 + +=item * + +L<File::KeePass> + +=item * + +L<File::KeePass::KDBX> + +=back + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Dumper/Raw.pm b/lib/File/KDBX/Dumper/Raw.pm new file mode 100644 index 0000000..3507c45 --- /dev/null +++ b/lib/File/KDBX/Dumper/Raw.pm @@ -0,0 +1,97 @@ +package File::KDBX::Dumper::Raw; +# ABSTRACT: A no-op dumper that dumps content as-is + +use warnings; +use strict; + +use File::KDBX::Util qw(:class); +use namespace::clean; + +extends 'File::KDBX::Dumper'; + +our $VERSION = '0.800'; # VERSION + +sub _dump { + my $self = shift; + my $fh = shift; + + $self->_write_body($fh); +} + +sub _write_headers { '' } + +sub _write_body { + my $self = shift; + my $fh = shift; + + $self->_write_inner_body($fh); +} + +sub _write_inner_body { + my $self = shift; + my $fh = shift; + + $fh->print($self->kdbx->raw); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Dumper::Raw - A no-op dumper that dumps content as-is + +=head1 VERSION + +version 0.800 + +=head1 SYNOPSIS + + use File::KDBX::Dumper; + use File::KDBX; + + my $kdbx = File::KDBX->new; + $kdbx->raw("Secret file contents\n"); + + $kdbx->dump_file('file.kdbx', $key, inner_format => 'Raw'); + # OR + File::KDBX::Dumper->dump_file('file.kdbx', $key, + kdbx => $kdbx, + inner_format => 'Raw', + ); + +=head1 DESCRIPTION + +A typical KDBX file is made up of an outer section (with headers) and an inner section (with the body). The +inner section is usually dumped using L<File::KDBX::Dumper::XML>, but you can use the +B<File::KDBX::Dumper::Raw> dumper to just write some arbitrary data as the body content. The result won't +necessarily be parseable by typical KeePass implementations, but it can be read back using +L<File::KDBX::Loader::Raw>. It's a way to encrypt any file with the same high level of security as a KDBX +database. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Dumper/V3.pm b/lib/File/KDBX/Dumper/V3.pm new file mode 100644 index 0000000..2fe585c --- /dev/null +++ b/lib/File/KDBX/Dumper/V3.pm @@ -0,0 +1,214 @@ +package File::KDBX::Dumper::V3; +# ABSTRACT: Dump KDBX3 files + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use Encode qw(encode); +use File::KDBX::Constants qw(:header :compression); +use File::KDBX::Error; +use File::KDBX::IO::Crypt; +use File::KDBX::IO::HashBlock; +use File::KDBX::Util qw(:class :empty :load assert_64bit erase_scoped); +use IO::Handle; +use namespace::clean; + +extends 'File::KDBX::Dumper'; + +our $VERSION = '0.800'; # VERSION + +sub _write_headers { + my $self = shift; + my $fh = shift; + + my $kdbx = $self->kdbx; + my $headers = $kdbx->headers; + my $buf = ''; + + # FIXME kinda janky - maybe add a "prepare" hook to massage the KDBX into the correct shape before we get + # this far + local $headers->{+HEADER_TRANSFORM_SEED} = $kdbx->transform_seed; + local $headers->{+HEADER_TRANSFORM_ROUNDS} = $kdbx->transform_rounds; + + if (nonempty (my $comment = $headers->{+HEADER_COMMENT})) { + $buf .= $self->_write_header($fh, HEADER_COMMENT, $comment); + } + for my $type ( + HEADER_CIPHER_ID, + HEADER_COMPRESSION_FLAGS, + HEADER_MASTER_SEED, + HEADER_TRANSFORM_SEED, + HEADER_TRANSFORM_ROUNDS, + HEADER_ENCRYPTION_IV, + HEADER_INNER_RANDOM_STREAM_KEY, + HEADER_STREAM_START_BYTES, + HEADER_INNER_RANDOM_STREAM_ID, + ) { + defined $headers->{$type} or throw "Missing value for required header: $type", type => $type; + $buf .= $self->_write_header($fh, $type, $headers->{$type}); + } + $buf .= $self->_write_header($fh, HEADER_END); + + return $buf; +} + +sub _write_header { + my $self = shift; + my $fh = shift; + my $type = shift; + my $val = shift // ''; + + $type = to_header_constant($type); + if ($type == HEADER_END) { + $val = "\r\n\r\n"; + } + elsif ($type == HEADER_COMMENT) { + $val = encode('UTF-8', $val); + } + elsif ($type == HEADER_CIPHER_ID) { + my $size = length($val); + $size == 16 or throw 'Invalid cipher UUID length', got => $size, expected => $size; + } + elsif ($type == HEADER_COMPRESSION_FLAGS) { + $val = pack('L<', $val); + } + elsif ($type == HEADER_MASTER_SEED) { + my $size = length($val); + $size == 32 or throw 'Invalid master seed length', got => $size, expected => $size; + } + elsif ($type == HEADER_TRANSFORM_SEED) { + # nothing + } + elsif ($type == HEADER_TRANSFORM_ROUNDS) { + assert_64bit; + $val = pack('Q<', $val); + } + elsif ($type == HEADER_ENCRYPTION_IV) { + # nothing + } + elsif ($type == HEADER_INNER_RANDOM_STREAM_KEY) { + # nothing + } + elsif ($type == HEADER_STREAM_START_BYTES) { + # nothing + } + elsif ($type == HEADER_INNER_RANDOM_STREAM_ID) { + $val = pack('L<', $val); + } + elsif ($type == HEADER_KDF_PARAMETERS || + $type == HEADER_PUBLIC_CUSTOM_DATA) { + throw "Unexpected KDBX4 header: $type", type => $type; + } + elsif ($type == HEADER_COMMENT) { + throw "Unexpected KDB header: $type", type => $type; + } + else { + alert "Unknown header: $type", type => $type; + } + + my $size = length($val); + my $buf = pack('C S<', 0+$type, $size); + + $fh->print($buf, $val) or throw 'Failed to write header'; + + return "$buf$val"; +} + +sub _write_body { + my $self = shift; + my $fh = shift; + my $key = shift; + my $header_data = shift; + my $kdbx = $self->kdbx; + + # assert all required headers present + for my $field ( + HEADER_CIPHER_ID, + HEADER_ENCRYPTION_IV, + HEADER_MASTER_SEED, + HEADER_INNER_RANDOM_STREAM_KEY, + HEADER_STREAM_START_BYTES, + ) { + defined $kdbx->headers->{$field} or throw "Missing $field"; + } + + my $master_seed = $kdbx->headers->{+HEADER_MASTER_SEED}; + + my @cleanup; + $key = $kdbx->composite_key($key); + + my $response = $key->challenge($master_seed); + push @cleanup, erase_scoped $response; + + my $transformed_key = $kdbx->kdf->transform($key); + push @cleanup, erase_scoped $transformed_key; + + my $final_key = digest_data('SHA256', $master_seed, $response, $transformed_key); + push @cleanup, erase_scoped $final_key; + + my $cipher = $kdbx->cipher(key => $final_key); + $fh = File::KDBX::IO::Crypt->new($fh, cipher => $cipher); + + $fh->print($kdbx->headers->{+HEADER_STREAM_START_BYTES}) + or throw 'Failed to write start bytes'; + $fh->flush; + + $kdbx->key($key); + + $fh = File::KDBX::IO::HashBlock->new($fh); + + my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS}; + if ($compress == COMPRESSION_GZIP) { + load_optional('IO::Compress::Gzip'); + $fh = IO::Compress::Gzip->new($fh, + -Level => IO::Compress::Gzip::Z_BEST_COMPRESSION(), + -TextFlag => 1, + ) or throw "Failed to initialize compression library: $IO::Compress::Gzip::GzipError", + error => $IO::Compress::Gzip::GzipError; + } + elsif ($compress != COMPRESSION_NONE) { + throw "Unsupported compression ($compress)\n", compression_flags => $compress; + } + + my $header_hash = digest_data('SHA256', $header_data); + $self->_write_inner_body($fh, $header_hash); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Dumper::V3 - Dump KDBX3 files + +=head1 VERSION + +version 0.800 + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Dumper/V4.pm b/lib/File/KDBX/Dumper/V4.pm new file mode 100644 index 0000000..ac5487f --- /dev/null +++ b/lib/File/KDBX/Dumper/V4.pm @@ -0,0 +1,402 @@ +package File::KDBX::Dumper::V4; +# ABSTRACT: Dump KDBX4 files + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use Crypt::Mac::HMAC qw(hmac); +use Encode qw(encode is_utf8); +use File::KDBX::Constants qw(:header :inner_header :compression :kdf :variant_map); +use File::KDBX::Error; +use File::KDBX::IO::Crypt; +use File::KDBX::IO::HmacBlock; +use File::KDBX::Util qw(:class :empty :load assert_64bit erase_scoped); +use IO::Handle; +use Scalar::Util qw(looks_like_number); +use boolean qw(:all); +use namespace::clean; + +extends 'File::KDBX::Dumper'; + +our $VERSION = '0.800'; # VERSION + +has _binaries_written => {}, is => 'ro'; + +sub _write_headers { + my $self = shift; + my $fh = shift; + + my $kdbx = $self->kdbx; + my $headers = $kdbx->headers; + my $buf = ''; + + # Always write the standard AES KDF UUID, for compatibility + local $headers->{+HEADER_KDF_PARAMETERS}->{+KDF_PARAM_UUID} = KDF_UUID_AES + if $headers->{+HEADER_KDF_PARAMETERS}->{+KDF_PARAM_UUID} eq KDF_UUID_AES_CHALLENGE_RESPONSE; + + if (nonempty (my $comment = $headers->{+HEADER_COMMENT})) { + $buf .= $self->_write_header($fh, HEADER_COMMENT, $comment); + } + for my $type ( + HEADER_CIPHER_ID, + HEADER_COMPRESSION_FLAGS, + HEADER_MASTER_SEED, + HEADER_ENCRYPTION_IV, + HEADER_KDF_PARAMETERS, + ) { + defined $headers->{$type} or throw "Missing value for required header: $type", type => $type; + $buf .= $self->_write_header($fh, $type, $headers->{$type}); + } + $buf .= $self->_write_header($fh, HEADER_PUBLIC_CUSTOM_DATA, $headers->{+HEADER_PUBLIC_CUSTOM_DATA}) + if defined $headers->{+HEADER_PUBLIC_CUSTOM_DATA} && keys %{$headers->{+HEADER_PUBLIC_CUSTOM_DATA}}; + $buf .= $self->_write_header($fh, HEADER_END); + + return $buf; +} + +sub _write_header { + my $self = shift; + my $fh = shift; + my $type = shift; + my $val = shift // ''; + + $type = to_header_constant($type); + if ($type == HEADER_END) { + # nothing + } + elsif ($type == HEADER_COMMENT) { + $val = encode('UTF-8', $val); + } + elsif ($type == HEADER_CIPHER_ID) { + my $size = length($val); + $size == 16 or throw 'Invalid cipher UUID length', got => $size, expected => $size; + } + elsif ($type == HEADER_COMPRESSION_FLAGS) { + $val = pack('L<', $val); + } + elsif ($type == HEADER_MASTER_SEED) { + my $size = length($val); + $size == 32 or throw 'Invalid master seed length', got => $size, expected => $size; + } + elsif ($type == HEADER_ENCRYPTION_IV) { + # nothing + } + elsif ($type == HEADER_KDF_PARAMETERS) { + $val = $self->_write_variant_dictionary($val, { + KDF_PARAM_UUID() => VMAP_TYPE_BYTEARRAY, + KDF_PARAM_AES_ROUNDS() => VMAP_TYPE_UINT64, + KDF_PARAM_AES_SEED() => VMAP_TYPE_BYTEARRAY, + KDF_PARAM_ARGON2_SALT() => VMAP_TYPE_BYTEARRAY, + KDF_PARAM_ARGON2_PARALLELISM() => VMAP_TYPE_UINT32, + KDF_PARAM_ARGON2_MEMORY() => VMAP_TYPE_UINT64, + KDF_PARAM_ARGON2_ITERATIONS() => VMAP_TYPE_UINT64, + KDF_PARAM_ARGON2_VERSION() => VMAP_TYPE_UINT32, + KDF_PARAM_ARGON2_SECRET() => VMAP_TYPE_BYTEARRAY, + KDF_PARAM_ARGON2_ASSOCDATA() => VMAP_TYPE_BYTEARRAY, + }); + } + elsif ($type == HEADER_PUBLIC_CUSTOM_DATA) { + $val = $self->_write_variant_dictionary($val); + } + elsif ($type == HEADER_INNER_RANDOM_STREAM_ID || + $type == HEADER_INNER_RANDOM_STREAM_KEY || + $type == HEADER_TRANSFORM_SEED || + $type == HEADER_TRANSFORM_ROUNDS || + $type == HEADER_STREAM_START_BYTES) { + throw "Unexpected KDBX3 header: $type", type => $type; + } + elsif ($type == HEADER_COMMENT) { + throw "Unexpected KDB header: $type", type => $type; + } + else { + alert "Unknown header: $type", type => $type; + } + + my $size = length($val); + my $buf = pack('C L<', 0+$type, $size); + + $fh->print($buf, $val) or throw 'Failed to write header'; + + return "$buf$val"; +} + +sub _intuit_variant_type { + my $self = shift; + my $variant = shift; + + if (isBoolean($variant)) { + return VMAP_TYPE_BOOL; + } + elsif (looks_like_number($variant) && ($variant + 0) =~ /^\d+$/) { + assert_64bit; + my $neg = $variant < 0; + my @b = unpack('L>2', pack('Q>', $variant)); + return VMAP_TYPE_INT64 if $b[0] && $neg; + return VMAP_TYPE_UINT64 if $b[0]; + return VMAP_TYPE_INT32 if $neg; + return VMAP_TYPE_UINT32; + } + elsif (is_utf8($variant)) { + return VMAP_TYPE_STRING; + } + return VMAP_TYPE_BYTEARRAY; +} + +sub _write_variant_dictionary { + my $self = shift; + my $dict = shift || {}; + my $types = shift || {}; + + my $buf = ''; + + $buf .= pack('S<', VMAP_VERSION); + + for my $key (sort keys %$dict) { + my $val = $dict->{$key}; + + my $type = $types->{$key} // $self->_intuit_variant_type($val); + $buf .= pack('C', $type); + + if ($type == VMAP_TYPE_UINT32) { + $val = pack('L<', $val); + } + elsif ($type == VMAP_TYPE_UINT64) { + assert_64bit; + $val = pack('Q<', $val); + } + elsif ($type == VMAP_TYPE_BOOL) { + $val = pack('C', $val); + } + elsif ($type == VMAP_TYPE_INT32) { + $val = pack('l', $val); + } + elsif ($type == VMAP_TYPE_INT64) { + assert_64bit; + $val = pack('q<', $val); + } + elsif ($type == VMAP_TYPE_STRING) { + $val = encode('UTF-8', $val); + } + elsif ($type == VMAP_TYPE_BYTEARRAY) { + # $val = substr($$buf, $pos, $vlen); + # $val = [split //, $val]; + } + else { + throw 'Unknown variant dictionary value type', type => $type; + } + + my ($klen, $vlen) = (length($key), length($val)); + $buf .= pack("L< a$klen L< a$vlen", $klen, $key, $vlen, $val); + } + + $buf .= pack('C', VMAP_TYPE_END); + + return $buf; +} + +sub _write_body { + my $self = shift; + my $fh = shift; + my $key = shift; + my $header_data = shift; + my $kdbx = $self->kdbx; + + # assert all required headers present + for my $field ( + HEADER_CIPHER_ID, + HEADER_ENCRYPTION_IV, + HEADER_MASTER_SEED, + ) { + defined $kdbx->headers->{$field} or throw "Missing header: $field"; + } + + my @cleanup; + + # write 32-byte checksum + my $header_hash = digest_data('SHA256', $header_data); + $fh->print($header_hash) or throw 'Failed to write header hash'; + + $key = $kdbx->composite_key($key); + my $transformed_key = $kdbx->kdf->transform($key); + push @cleanup, erase_scoped $transformed_key; + + # write 32-byte HMAC for header + my $hmac_key = digest_data('SHA512', $kdbx->headers->{master_seed}, $transformed_key, "\x01"); + push @cleanup, erase_scoped $hmac_key; + my $header_hmac = hmac('SHA256', + digest_data('SHA512', "\xff\xff\xff\xff\xff\xff\xff\xff", $hmac_key), + $header_data, + ); + $fh->print($header_hmac) or throw 'Failed to write header HMAC'; + + $kdbx->key($key); + + # HMAC-block the rest of the stream + $fh = File::KDBX::IO::HmacBlock->new($fh, key => $hmac_key); + + my $final_key = digest_data('SHA256', $kdbx->headers->{master_seed}, $transformed_key); + push @cleanup, erase_scoped $final_key; + + my $cipher = $kdbx->cipher(key => $final_key); + $fh = File::KDBX::IO::Crypt->new($fh, cipher => $cipher); + + my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS}; + if ($compress == COMPRESSION_GZIP) { + load_optional('IO::Compress::Gzip'); + $fh = IO::Compress::Gzip->new($fh, + -Level => IO::Compress::Gzip::Z_BEST_COMPRESSION(), + -TextFlag => 1, + ) or throw "Failed to initialize compression library: $IO::Compress::Gzip::GzipError", + error => $IO::Compress::Gzip::GzipError; + } + elsif ($compress != COMPRESSION_NONE) { + throw "Unsupported compression ($compress)\n", compression_flags => $compress; + } + + $self->_write_inner_headers($fh); + + local $self->{compress_datetimes} = 1; + $self->_write_inner_body($fh, $header_hash); +} + +sub _write_inner_headers { + my $self = shift; + my $fh = shift; + + my $kdbx = $self->kdbx; + my $headers = $kdbx->inner_headers; + + for my $type ( + INNER_HEADER_INNER_RANDOM_STREAM_ID, + INNER_HEADER_INNER_RANDOM_STREAM_KEY, + ) { + defined $headers->{$type} or throw "Missing inner header: $type"; + $self->_write_inner_header($fh, $type => $headers->{$type}); + } + + $self->_write_binaries($fh); + + $self->_write_inner_header($fh, INNER_HEADER_END); +} + +sub _write_inner_header { + my $self = shift; + my $fh = shift; + my $type = shift; + my $val = shift // ''; + + my $buf = pack('C', $type); + $fh->print($buf) or throw 'Failed to write inner header type'; + + $type = to_inner_header_constant($type); + if ($type == INNER_HEADER_END) { + # nothing + } + elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_ID) { + $val = pack('L<', $val); + } + elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_KEY) { + # nothing + } + elsif ($type == INNER_HEADER_BINARY) { + # nothing + } + + $buf = pack('L<', length($val)); + $fh->print($buf) or throw 'Failed to write inner header value size'; + $fh->print($val) or throw 'Failed to write inner header value'; +} + +sub _write_binaries { + my $self = shift; + my $fh = shift; + + my $kdbx = $self->kdbx; + + my $new_ref = 0; + my $written = $self->_binaries_written; + + my $entries = $kdbx->entries(history => 1); + while (my $entry = $entries->next) { + for my $key (keys %{$entry->binaries}) { + my $binary = $entry->binaries->{$key}; + if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) { + $binary = $kdbx->binaries->{$binary->{ref}}; + } + + if (!defined $binary->{value}) { + alert "Skipping binary which has no value: $key", key => $key; + next; + } + + my $hash = digest_data('SHA256', $binary->{value}); + if (defined $written->{$hash}) { + # nothing + } + else { + my $flags = 0; + $flags &= INNER_HEADER_BINARY_FLAG_PROTECT if $binary->{protect}; + + $self->_write_binary($fh, \$binary->{value}, $flags); + $written->{$hash} = $new_ref++; + } + } + } +} + +sub _write_binary { + my $self = shift; + my $fh = shift; + my $data = shift; + my $flags = shift || 0; + + my $buf = pack('C', 0 + INNER_HEADER_BINARY); + $fh->print($buf) or throw 'Failed to write inner header type'; + + $buf = pack('L<', 1 + length($$data)); + $fh->print($buf) or throw 'Failed to write inner header value size'; + + $buf = pack('C', $flags); + $fh->print($buf) or throw 'Failed to write inner header binary flags'; + + $fh->print($$data) or throw 'Failed to write inner header value'; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Dumper::V4 - Dump KDBX4 files + +=head1 VERSION + +version 0.800 + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Dumper/XML.pm b/lib/File/KDBX/Dumper/XML.pm new file mode 100644 index 0000000..e47c629 --- /dev/null +++ b/lib/File/KDBX/Dumper/XML.pm @@ -0,0 +1,646 @@ +package File::KDBX::Dumper::XML; +# ABSTRACT: Dump unencrypted XML KeePass files + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use Crypt::Misc 0.029 qw(encode_b64); +use Encode qw(encode); +use File::KDBX::Constants qw(:version :time); +use File::KDBX::Error; +use File::KDBX::Util qw(:class assert_64bit erase_scoped gzip snakify); +use IO::Handle; +use Scalar::Util qw(blessed isdual looks_like_number); +use Time::Piece; +use XML::LibXML; +use boolean; +use namespace::clean; + +extends 'File::KDBX::Dumper'; + +our $VERSION = '0.800'; # VERSION + + +has allow_protection => 1; +has binaries => sub { $_[0]->kdbx->version < KDBX_VERSION_4_0 }; +has 'compress_binaries'; +has 'compress_datetimes'; + +sub header_hash { $_[0]->{header_hash} } + +sub _binaries_written { $_[0]->{_binaries_written} //= {} } + +sub _random_stream { $_[0]->{random_stream} //= $_[0]->kdbx->random_stream } + +sub _dump { + my $self = shift; + my $fh = shift; + + $self->_write_inner_body($fh, $self->header_hash); +} + +sub _write_inner_body { + my $self = shift; + my $fh = shift; + my $header_hash = shift; + + my $dom = XML::LibXML::Document->new('1.0', 'UTF-8'); + $dom->setStandalone(1); + + my $doc = XML::LibXML::Element->new('KeePassFile'); + $dom->setDocumentElement($doc); + + my $meta = XML::LibXML::Element->new('Meta'); + $doc->appendChild($meta); + $self->_write_xml_meta($meta, $header_hash); + + my $root = XML::LibXML::Element->new('Root'); + $doc->appendChild($root); + $self->_write_xml_root($root); + + $dom->toFH($fh, 1); +} + +sub _write_xml_meta { + my $self = shift; + my $node = shift; + my $header_hash = shift; + + my $meta = $self->kdbx->meta; + local $meta->{generator} = $self->kdbx->user_agent_string // __PACKAGE__; + local $meta->{header_hash} = $header_hash; + + $self->_write_xml_from_pairs($node, $meta, + Generator => 'text', + $self->kdbx->version < KDBX_VERSION_4_0 && defined $meta->{header_hash} ? ( + HeaderHash => 'binary', + ) : (), + DatabaseName => 'text', + DatabaseNameChanged => 'datetime', + DatabaseDescription => 'text', + DatabaseDescriptionChanged => 'datetime', + DefaultUserName => 'text', + DefaultUserNameChanged => 'datetime', + MaintenanceHistoryDays => 'number', + Color => 'text', + MasterKeyChanged => 'datetime', + MasterKeyChangeRec => 'number', + MasterKeyChangeForce => 'number', + MemoryProtection => \&_write_xml_memory_protection, + CustomIcons => \&_write_xml_custom_icons, + RecycleBinEnabled => 'bool', + RecycleBinUUID => 'uuid', + RecycleBinChanged => 'datetime', + EntryTemplatesGroup => 'uuid', + EntryTemplatesGroupChanged => 'datetime', + LastSelectedGroup => 'uuid', + LastTopVisibleGroup => 'uuid', + HistoryMaxItems => 'number', + HistoryMaxSize => 'number', + $self->kdbx->version >= KDBX_VERSION_4_0 ? ( + SettingsChanged => 'datetime', + ) : (), + $self->kdbx->version < KDBX_VERSION_4_0 || $self->binaries ? ( + Binaries => \&_write_xml_binaries, + ) : (), + CustomData => \&_write_xml_custom_data, + ); +} + +sub _write_xml_memory_protection { + my $self = shift; + my $node = shift; + + my $memory_protection = $self->kdbx->meta->{memory_protection}; + + $self->_write_xml_from_pairs($node, $memory_protection, + ProtectTitle => 'bool', + ProtectUserName => 'bool', + ProtectPassword => 'bool', + ProtectURL => 'bool', + ProtectNotes => 'bool', + # AutoEnableVisualHiding => 'bool', + ); +} + +sub _write_xml_binaries { + my $self = shift; + my $node = shift; + + my $kdbx = $self->kdbx; + + my $new_ref = keys %{$self->_binaries_written}; + my $written = $self->_binaries_written; + + my $entries = $kdbx->entries(history => 1); + while (my $entry = $entries->next) { + for my $key (keys %{$entry->binaries}) { + my $binary = $entry->binaries->{$key}; + if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) { + $binary = $kdbx->binaries->{$binary->{ref}}; + } + + if (!defined $binary->{value}) { + alert "Skipping binary which has no value: $key", key => $key; + next; + } + + my $hash = digest_data('SHA256', $binary->{value}); + if (defined $written->{$hash}) { + # nothing + } + else { + my $binary_node = $node->addNewChild(undef, 'Binary'); + $binary_node->setAttribute('ID', _encode_text($new_ref)); + $binary_node->setAttribute('Protected', _encode_bool(true)) if $binary->{protect}; + $self->_write_xml_compressed_content($binary_node, \$binary->{value}, $binary->{protect}); + $written->{$hash} = $new_ref++; + } + } + } +} + +sub _write_xml_compressed_content { + my $self = shift; + my $node = shift; + my $value = shift; + my $protect = shift; + + my @cleanup; + + my $encoded; + if (utf8::is_utf8($$value)) { + $encoded = encode('UTF-8', $$value); + push @cleanup, erase_scoped $encoded; + $value = \$encoded; + } + + my $should_compress = $self->compress_binaries; + my $try_compress = $should_compress || !defined $should_compress; + + my $compressed; + if ($try_compress) { + $compressed = gzip($$value); + push @cleanup, erase_scoped $compressed; + + if ($should_compress || length($compressed) < length($$value)) { + $value = \$compressed; + $node->setAttribute('Compressed', _encode_bool(true)); + } + } + + my $encrypted; + if ($protect) { + $encrypted = $self->_random_stream->crypt($$value); + push @cleanup, erase_scoped $encrypted; + $value = \$encrypted; + } + + $node->appendText(_encode_binary($$value)); +} + +sub _write_xml_custom_icons { + my $self = shift; + my $node = shift; + + my $custom_icons = $self->kdbx->custom_icons; + + for my $icon (@$custom_icons) { + $icon->{uuid} && $icon->{data} or next; + my $icon_node = $node->addNewChild(undef, 'Icon'); + + $self->_write_xml_from_pairs($icon_node, $icon, + UUID => 'uuid', + Data => 'binary', + KDBX_VERSION_4_1 <= $self->kdbx->version ? ( + Name => 'text', + LastModificationTime => 'datetime', + ) : (), + ); + } +} + +sub _write_xml_custom_data { + my $self = shift; + my $node = shift; + my $custom_data = shift || {}; + + for my $key (sort keys %$custom_data) { + my $item = $custom_data->{$key}; + my $item_node = $node->addNewChild(undef, 'Item'); + + local $item->{key} = $key if !defined $item->{key}; + + $self->_write_xml_from_pairs($item_node, $item, + Key => 'text', + Value => 'text', + KDBX_VERSION_4_1 <= $self->kdbx->version ? ( + LastModificationTime => 'datetime', + ) : (), + ); + } +} + +sub _write_xml_root { + my $self = shift; + my $node = shift; + my $kdbx = $self->kdbx; + + my $guard = $kdbx->unlock_scoped; + + if (my $group = $kdbx->root) { + my $group_node = $node->addNewChild(undef, 'Group'); + $self->_write_xml_group($group_node, $group->_committed); + } + + undef $guard; # re-lock if needed, as early as possible + + my $deleted_objects_node = $node->addNewChild(undef, 'DeletedObjects'); + $self->_write_xml_deleted_objects($deleted_objects_node); +} + +sub _write_xml_group { + my $self = shift; + my $node = shift; + my $group = shift; + + $self->_write_xml_from_pairs($node, $group, + UUID => 'uuid', + Name => 'text', + Notes => 'text', + KDBX_VERSION_4_1 <= $self->kdbx->version ? ( + Tags => 'text', + ) : (), + IconID => 'number', + defined $group->{custom_icon_uuid} ? ( + CustomIconUUID => 'uuid', + ) : (), + Times => \&_write_xml_times, + IsExpanded => 'bool', + DefaultAutoTypeSequence => 'text', + EnableAutoType => 'tristate', + EnableSearching => 'tristate', + LastTopVisibleEntry => 'uuid', + KDBX_VERSION_4_0 <= $self->kdbx->version ? ( + CustomData => \&_write_xml_custom_data, + ) : (), + KDBX_VERSION_4_1 <= $self->kdbx->version ? ( + PreviousParentGroup => 'uuid', + ) : (), + ); + + for my $entry (@{$group->entries}) { + my $entry_node = $node->addNewChild(undef, 'Entry'); + $self->_write_xml_entry($entry_node, $entry->_committed); + } + + for my $group (@{$group->groups}) { + my $group_node = $node->addNewChild(undef, 'Group'); + $self->_write_xml_group($group_node, $group->_committed); + } +} + +sub _write_xml_entry { + my $self = shift; + my $node = shift; + my $entry = shift; + my $in_history = shift; + + $self->_write_xml_from_pairs($node, $entry, + UUID => 'uuid', + IconID => 'number', + defined $entry->{custom_icon_uuid} ? ( + CustomIconUUID => 'uuid', + ) : (), + ForegroundColor => 'text', + BackgroundColor => 'text', + OverrideURL => 'text', + Tags => 'text', + Times => \&_write_xml_times, + KDBX_VERSION_4_1 <= $self->kdbx->version ? ( + QualityCheck => 'bool', + PreviousParentGroup => 'uuid', + ) : (), + ); + + for my $key (sort keys %{$entry->{strings} || {}}) { + my $string = $entry->{strings}{$key}; + my $string_node = $node->addNewChild(undef, 'String'); + local $string->{key} = $string->{key} // $key; + $self->_write_xml_entry_string($string_node, $string); + } + + my $kdbx = $self->kdbx; + my $new_ref = keys %{$self->_binaries_written}; + my $written = $self->_binaries_written; + + for my $key (sort keys %{$entry->{binaries} || {}}) { + my $binary = $entry->binaries->{$key}; + if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) { + $binary = $kdbx->binaries->{$binary->{ref}}; + } + + if (!defined $binary->{value}) { + alert "Skipping binary which has no value: $key", key => $key; + next; + } + + my $binary_node = $node->addNewChild(undef, 'Binary'); + $binary_node->addNewChild(undef, 'Key')->appendText(_encode_text($key)); + my $value_node = $binary_node->addNewChild(undef, 'Value'); + + my $hash = digest_data('SHA256', $binary->{value}); + if (defined $written->{$hash}) { + # write reference + $value_node->setAttribute('Ref', _encode_text($written->{$hash})); + } + else { + # write actual binary + $value_node->setAttribute('Protected', _encode_bool(true)) if $binary->{protect}; + $self->_write_xml_compressed_content($value_node, \$binary->{value}, $binary->{protect}); + $written->{$hash} = $new_ref++; + } + } + + $self->_write_xml_from_pairs($node, $entry, + AutoType => \&_write_xml_entry_auto_type, + ); + + $self->_write_xml_from_pairs($node, $entry, + KDBX_VERSION_4_0 <= $self->kdbx->version ? ( + CustomData => \&_write_xml_custom_data, + ) : (), + ); + + if (!$in_history) { + if (my @history = @{$entry->history}) { + my $history_node = $node->addNewChild(undef, 'History'); + for my $historical (@history) { + my $historical_node = $history_node->addNewChild(undef, 'Entry'); + $self->_write_xml_entry($historical_node, $historical->_committed, 1); + } + } + } +} + +sub _write_xml_entry_auto_type { + my $self = shift; + my $node = shift; + my $autotype = shift; + + $self->_write_xml_from_pairs($node, $autotype, + Enabled => 'bool', + DataTransferObfuscation => 'number', + DefaultSequence => 'text', + ); + + for my $association (@{$autotype->{associations} || []}) { + my $association_node = $node->addNewChild(undef, 'Association'); + $self->_write_xml_from_pairs($association_node, $association, + Window => 'text', + KeystrokeSequence => 'text', + ); + } +} + +sub _write_xml_times { + my $self = shift; + my $node = shift; + my $times = shift; + + $self->_write_xml_from_pairs($node, $times, + LastModificationTime => 'datetime', + CreationTime => 'datetime', + LastAccessTime => 'datetime', + ExpiryTime => 'datetime', + Expires => 'bool', + UsageCount => 'number', + LocationChanged => 'datetime', + ); +} + +sub _write_xml_entry_string { + my $self = shift; + my $node = shift; + my $string = shift; + + my @cleanup; + + my $kdbx = $self->kdbx; + my $key = $string->{key}; + + $node->addNewChild(undef, 'Key')->appendText(_encode_text($key)); + my $value_node = $node->addNewChild(undef, 'Value'); + + my $value = $string->{value} || ''; + + my $memory_protection = $kdbx->meta->{memory_protection}; + my $memprot_key = 'protect_' . snakify($key); + my $protect = $string->{protect} || $memory_protection->{$memprot_key}; + + if ($protect) { + if ($self->allow_protection) { + my $encoded; + if (utf8::is_utf8($value)) { + $encoded = encode('UTF-8', $value); + push @cleanup, erase_scoped $encoded; + $value = $encoded; + } + + $value_node->setAttribute('Protected', _encode_bool(true)); + $value = _encode_binary($self->_random_stream->crypt(\$value)); + } + else { + $value_node->setAttribute('ProtectInMemory', _encode_bool(true)); + $value = _encode_text($value); + } + } + else { + $value = _encode_text($value); + } + + $value_node->appendText($value) if defined $value; +} + +sub _write_xml_deleted_objects { + my $self = shift; + my $node = shift; + + my $objects = $self->kdbx->deleted_objects; + + for my $uuid (sort keys %{$objects || {}}) { + my $object = $objects->{$uuid}; + local $object->{uuid} = $uuid; + my $object_node = $node->addNewChild(undef, 'DeletedObject'); + $self->_write_xml_from_pairs($object_node, $object, + UUID => 'uuid', + DeletionTime => 'datetime', + ); + } +} + +############################################################################## + +sub _write_xml_from_pairs { + my $self = shift; + my $node = shift; + my $hash = shift; + my @spec = @_; + + while (@spec) { + my ($name, $type) = splice @spec, 0, 2; + my $key = snakify($name); + + if (ref $type eq 'CODE') { + my $child_node = $node->addNewChild(undef, $name); + $self->$type($child_node, $hash->{$key}); + } + else { + next if !exists $hash->{$key}; + my $child_node = $node->addNewChild(undef, $name); + $type = 'datetime_binary' if $type eq 'datetime' && $self->compress_datetimes; + $child_node->appendText(_encode_primitive($hash->{$key}, $type)); + } + } +} + +############################################################################## + +sub _encode_primitive { goto &{__PACKAGE__."::_encode_$_[1]"} } + +sub _encode_binary { + return '' if !defined $_[0] || (ref $_[0] && !defined $$_[0]); + return encode_b64(ref $_[0] ? $$_[0] : $_[0]); +} + +sub _encode_bool { + local $_ = shift; + return $_ ? 'True' : 'False'; +} + +sub _encode_datetime { + local $_ = shift; + return $_->strftime('%Y-%m-%dT%H:%M:%SZ'); +} + +sub _encode_datetime_binary { + local $_ = shift; + assert_64bit; + my $seconds_since_ad1 = $_ + TIME_SECONDS_AD1_TO_UNIX_EPOCH; + my $buf = pack('Q<', $seconds_since_ad1->epoch); + return eval { encode_b64($buf) }; +} + +sub _encode_tristate { + local $_ = shift // return 'null'; + return $_ ? 'True' : 'False'; +} + +sub _encode_number { + local $_ = shift // return; + looks_like_number($_) || isdual($_) or throw 'Expected number', text => $_; + return _encode_text($_+0); +} + +sub _encode_text { + return '' if !defined $_[0]; + return $_[0]; +} + +sub _encode_uuid { _encode_binary(@_) } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Dumper::XML - Dump unencrypted XML KeePass files + +=head1 VERSION + +version 0.800 + +=head1 ATTRIBUTES + +=head2 allow_protection + + $bool = $dumper->allow_protection; + +Get whether or not protected strings and binaries should be written in an encrypted stream. Default: C<TRUE> + +=head2 binaries + + $bool = $dumper->binaries; + +Get whether or not binaries within the database should be written. Default: C<TRUE> + +=head2 compress_binaries + + $tristate = $dumper->compress_binaries; + +Get whether or not to compress binaries. Possible values: + +=over 4 + +=item * + +C<TRUE> - Always compress binaries + +=item * + +C<FALSE> - Never compress binaries + +=item * + +C<undef> - Compress binaries if it results in smaller database sizes (default) + +=back + +=head2 compress_datetimes + + $bool = $dumper->compress_datetimes; + +Get whether or not to write compressed datetimes. Datetimes are traditionally written in the human-readable +string format of C<1970-01-01T00:00:00Z>, but they can also be written in a compressed form to save some +bytes. The default is to write compressed datetimes if the KDBX file version is 4+, otherwise use the +human-readable format. + +=head2 header_hash + + $octets = $dumper->header_hash; + +Get the value to be written as the B<HeaderHash> in the B<Meta> section. This is the way KDBX3 files validate +the authenticity of header data. This is unnecessary and should not be used with KDBX4 files because that +format uses HMAC-SHA256 to detect tampering. + +L<File::KDBX::Dumper::V3> automatically calculates the header hash an provides it to this module, and plain +XML files which don't have a KDBX wrapper don't have headers and so should have a header hash. Therefore there +is probably never any reason to set this manually. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Entry.pm b/lib/File/KDBX/Entry.pm new file mode 100644 index 0000000..d8acc70 --- /dev/null +++ b/lib/File/KDBX/Entry.pm @@ -0,0 +1,1687 @@ +package File::KDBX::Entry; +# ABSTRACT: A KDBX database entry + +use warnings; +use strict; + +use Crypt::Misc 0.029 qw(decode_b64 encode_b32r); +use Devel::GlobalDestruction; +use Encode qw(encode); +use File::KDBX::Constants qw(:history :icon); +use File::KDBX::Error; +use File::KDBX::Util qw(:assert :class :coercion :erase :function :uri generate_uuid load_optional); +use Hash::Util::FieldHash; +use List::Util qw(first sum0); +use Ref::Util qw(is_coderef is_hashref is_plain_hashref); +use Scalar::Util qw(blessed looks_like_number); +use Storable qw(dclone); +use Time::Piece; +use boolean; +use namespace::clean; + +extends 'File::KDBX::Object'; + +our $VERSION = '0.800'; # VERSION + +my $PLACEHOLDER_MAX_DEPTH = 10; +my %PLACEHOLDERS; +my %STANDARD_STRINGS = map { $_ => 1 } qw(Title UserName Password URL Notes); + + +sub uuid { + my $self = shift; + if (@_ || !defined $self->{uuid}) { + my %args = @_ % 2 == 1 ? (uuid => shift, @_) : @_; + my $old_uuid = $self->{uuid}; + my $uuid = $self->{uuid} = delete $args{uuid} // generate_uuid; + for my $entry (@{$self->history}) { + $entry->{uuid} = $uuid; + } + $self->_signal('uuid.changed', $uuid, $old_uuid) if defined $old_uuid && $self->is_current; + } + $self->{uuid}; +} + +# has uuid => sub { generate_uuid(printable => 1) }; +has icon_id => ICON_PASSWORD, coerce => \&to_icon_constant; +has custom_icon_uuid => undef, coerce => \&to_uuid; +has foreground_color => '', coerce => \&to_string; +has background_color => '', coerce => \&to_string; +has override_url => '', coerce => \&to_string; +has tags => '', coerce => \&to_string; +has auto_type => {}; +has previous_parent_group => undef, coerce => \&to_uuid; +has quality_check => true, coerce => \&to_bool; +has strings => {}; +has binaries => {}; +has times => {}; +# has custom_data => {}; +# has history => []; + +has last_modification_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has creation_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has last_access_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has expiry_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has expires => false, store => 'times', coerce => \&to_bool; +has usage_count => 0, store => 'times', coerce => \&to_number; +has location_changed => sub { gmtime }, store => 'times', coerce => \&to_time; + +# has 'auto_type.auto_type_enabled' => true, coerce => \&to_bool; +has 'auto_type_obfuscation' => 0, path => 'auto_type.data_transfer_obfuscation', + coerce => \&to_number; +has 'auto_type_default_sequence' => '{USERNAME}{TAB}{PASSWORD}{ENTER}', + path => 'auto_type.default_sequence', coerce => \&to_string; +has 'auto_type_associations' => [], path => 'auto_type.associations'; + +my %ATTRS_STRINGS = ( + title => 'Title', + username => 'UserName', + password => 'Password', + url => 'URL', + notes => 'Notes', +); +while (my ($attr, $string_key) = each %ATTRS_STRINGS) { + no strict 'refs'; ## no critic (ProhibitNoStrict) + *{$attr} = sub { shift->string_value($string_key, @_) }; + *{"expand_${attr}"} = sub { shift->expand_string_value($string_key, @_) }; +} + +my @ATTRS = qw(uuid custom_data history auto_type_enabled); +sub _set_nonlazy_attributes { + my $self = shift; + $self->$_ for @ATTRS, keys %ATTRS_STRINGS, list_attributes(ref $self); +} + +sub init { + my $self = shift; + my %args = @_; + + while (my ($key, $val) = each %args) { + if (my $method = $self->can($key)) { + $self->$method($val); + } + else { + $self->string($key => $val); + } + } + + return $self; +} + +############################################################################## + + +sub string { + my $self = shift; + my %args = @_ == 2 ? (key => shift, value => shift) + : @_ % 2 == 1 ? (key => shift, @_) : @_; + + if (!defined $args{key} && !defined $args{value}) { + my %standard = (value => 1, protect => 1); + my @other_keys = grep { !$standard{$_} } keys %args; + if (@other_keys == 1) { + my $key = $args{key} = $other_keys[0]; + $args{value} = delete $args{$key}; + } + } + + my $key = delete $args{key} or throw 'Must provide a string key to access'; + + return $self->{strings}{$key} = $args{value} if is_plain_hashref($args{value}); + + while (my ($field, $value) = each %args) { + $self->{strings}{$key}{$field} = $value; + } + + # Auto-vivify the standard strings. + if ($STANDARD_STRINGS{$key}) { + return $self->{strings}{$key} //= {value => '', $self->_protect($key) ? (protect => true) : ()}; + } + return $self->{strings}{$key}; +} + +### Get whether or not a standard string is configured to be protected +sub _protect { + my $self = shift; + my $key = shift; + return false if !$STANDARD_STRINGS{$key}; + if (my $kdbx = eval { $self->kdbx }) { + my $protect = $kdbx->memory_protection($key); + return $protect if defined $protect; + } + return $key eq 'Password'; +} + + +sub string_value { + my $self = shift; + my $string = $self->string(@_) // return undef; + return $string->{value}; +} + + +sub _expand_placeholder { + my $self = shift; + my $placeholder = shift; + my $arg = shift; + + require File::KDBX; + + my $placeholder_key = $placeholder; + if (defined $arg) { + $placeholder_key = $File::KDBX::PLACEHOLDERS{"${placeholder}:${arg}"} ? "${placeholder}:${arg}" + : "${placeholder}:"; + } + return if !defined $File::KDBX::PLACEHOLDERS{$placeholder_key}; + + my $local_key = join('/', Hash::Util::FieldHash::id($self), $placeholder_key); + local $PLACEHOLDERS{$local_key} = my $handler = $PLACEHOLDERS{$local_key} // do { + my $handler = $File::KDBX::PLACEHOLDERS{$placeholder_key} or next; + memoize recurse_limit($handler, $PLACEHOLDER_MAX_DEPTH, sub { + alert "Detected deep recursion while expanding $placeholder placeholder", + placeholder => $placeholder; + return; # undef + }); + }; + + return $handler->($self, $arg, $placeholder); +} + +sub _expand_string { + my $self = shift; + my $str = shift; + + my $expand = memoize $self->can('_expand_placeholder'), $self; + + # placeholders (including field references): + $str =~ s!\{([^:\}]+)(?::([^\}]*))?\}!$expand->(uc($1), $2, @_) // $&!egi; + + # environment variables (alt syntax): + my $vars = join('|', map { quotemeta($_) } keys %ENV); + $str =~ s!\%($vars)\%!$expand->(ENV => $1, @_) // $&!eg; + + return $str; +} + +sub expand_string_value { + my $self = shift; + my $str = $self->string_peek(@_) // return undef; + my $cleanup = erase_scoped $str; + return $self->_expand_string($str); +} + + +sub other_strings { + my $self = shift; + my $delim = shift // "\n"; + + my @strings = map { $self->string_value($_) } grep { !$STANDARD_STRINGS{$_} } sort keys %{$self->strings}; + return join($delim, @strings); +} + + +sub string_peek { + my $self = shift; + my $string = $self->string(@_); + return defined $string->{value} ? $string->{value} : $self->kdbx->peek($string); +} + +############################################################################## + + +sub add_auto_type_association { + my $self = shift; + my $association = shift; + push @{$self->auto_type_associations}, $association; +} + + +sub expand_keystroke_sequence { + my $self = shift; + my $association = shift; + + my $keys; + if ($association) { + $keys = is_hashref($association) && exists $association->{keystroke_sequence} ? + $association->{keystroke_sequence} : defined $association ? $association : ''; + } + + $keys = $self->auto_type_default_sequence if !$keys; + # TODO - Fall back to getting default sequence from parent group, which probably means we shouldn't be + # setting a default value in the entry.. + + return $self->_expand_string($keys); +} + +############################################################################## + + +sub binary { + my $self = shift; + my %args = @_ == 2 ? (key => shift, value => shift) + : @_ % 2 == 1 ? (key => shift, @_) : @_; + + if (!defined $args{key} && !defined $args{value}) { + my %standard = (value => 1, protect => 1); + my @other_keys = grep { !$standard{$_} } keys %args; + if (@other_keys == 1) { + my $key = $args{key} = $other_keys[0]; + $args{value} = delete $args{$key}; + } + } + + my $key = delete $args{key} or throw 'Must provide a binary key to access'; + + return $self->{binaries}{$key} = $args{value} if is_plain_hashref($args{value}); + + assert { !defined $args{value} || !utf8::is_utf8($args{value}) }; + while (my ($field, $value) = each %args) { + $self->{binaries}{$key}{$field} = $value; + } + return $self->{binaries}{$key}; +} + + +sub binary_value { + my $self = shift; + my $binary = $self->binary(@_) // return undef; + return $binary->{value}; +} + +############################################################################## + + +sub hmac_otp { + my $self = shift; + load_optional('Pass::OTP'); + + my %params = ($self->_hotp_params, @_); + return if !defined $params{type} || !defined $params{secret}; + + $params{secret} = encode_b32r($params{secret}) if !$params{base32}; + $params{base32} = 1; + + my $otp = eval {Pass::OTP::otp(%params, @_) }; + if (my $err = $@) { + throw 'Unable to generate HOTP', error => $err; + } + + $self->_hotp_increment_counter($params{counter}); + + return $otp; +} + + +sub time_otp { + my $self = shift; + load_optional('Pass::OTP'); + + my %params = ($self->_totp_params, @_); + return if !defined $params{type} || !defined $params{secret}; + + $params{secret} = encode_b32r($params{secret}) if !$params{base32}; + $params{base32} = 1; + + my $otp = eval {Pass::OTP::otp(%params, @_) }; + if (my $err = $@) { + throw 'Unable to generate TOTP', error => $err; + } + + return $otp; +} + + +sub hmac_otp_uri { $_[0]->_otp_uri($_[0]->_hotp_params) } +sub time_otp_uri { $_[0]->_otp_uri($_[0]->_totp_params) } + +sub _otp_uri { + my $self = shift; + my %params = @_; + + return if 4 != grep { defined } @params{qw(type secret issuer account)}; + return if $params{type} !~ /^[ht]otp$/i; + + my $label = delete $params{label}; + $params{$_} = uri_escape_utf8($params{$_}) for keys %params; + + my $type = lc($params{type}); + my $issuer = $params{issuer}; + my $account = $params{account}; + + $label //= "$issuer:$account"; + + my $secret = $params{secret}; + $secret = uc(encode_b32r($secret)) if !$params{base32}; + + delete $params{algorithm} if defined $params{algorithm} && $params{algorithm} eq 'sha1'; + delete $params{period} if defined $params{period} && $params{period} == 30; + delete $params{digits} if defined $params{digits} && $params{digits} == 6; + delete $params{counter} if defined $params{counter} && $params{counter} == 0; + + my $uri = "otpauth://$type/$label?secret=$secret&issuer=$issuer"; + + if (defined $params{encoder}) { + $uri .= "&encoder=$params{encoder}"; + return $uri; + } + $uri .= '&algorithm=' . uc($params{algorithm}) if defined $params{algorithm}; + $uri .= "&digits=$params{digits}" if defined $params{digits}; + $uri .= "&counter=$params{counter}" if defined $params{counter}; + $uri .= "&period=$params{period}" if defined $params{period}; + + return $uri; +} + +sub _hotp_params { + my $self = shift; + + my %params = ( + type => 'hotp', + issuer => $self->title || 'KDBX', + account => $self->username || 'none', + digits => 6, + counter => $self->string_value('HmacOtp-Counter') // 0, + $self->_otp_secret_params('Hmac'), + ); + return %params if $params{secret}; + + my %otp_params = $self->_otp_params; + return () if !$otp_params{secret} || $otp_params{type} ne 'hotp'; + + # $otp_params{counter} = 0 + + return (%params, %otp_params); +} + +sub _totp_params { + my $self = shift; + + my %algorithms = ( + 'HMAC-SHA-1' => 'sha1', + 'HMAC-SHA-256' => 'sha256', + 'HMAC-SHA-512' => 'sha512', + ); + my %params = ( + type => 'totp', + issuer => $self->title || 'KDBX', + account => $self->username || 'none', + digits => $self->string_value('TimeOtp-Length') // 6, + algorithm => $algorithms{$self->string_value('TimeOtp-Algorithm') || ''} || 'sha1', + period => $self->string_value('TimeOtp-Period') // 30, + $self->_otp_secret_params('Time'), + ); + return %params if $params{secret}; + + my %otp_params = $self->_otp_params; + return () if !$otp_params{secret} || $otp_params{type} ne 'totp'; + + return (%params, %otp_params); +} + +# KeePassXC style +sub _otp_params { + my $self = shift; + load_optional('Pass::OTP::URI'); + + my $uri = $self->string_value('otp') || ''; + my %params; + %params = Pass::OTP::URI::parse($uri) if $uri =~ m!^otpauth://!; + return () if !$params{secret} || !$params{type}; + + if (($params{encoder} // '') eq 'steam') { + $params{digits} = 5; + $params{chars} = '23456789BCDFGHJKMNPQRTVWXY'; + } + + # Pass::OTP::URI doesn't provide the issuer and account separately, so get them from the label + my ($issuer, $user) = split(':', $params{label} // ':', 2); + $params{issuer} //= uri_unescape_utf8($issuer); + $params{account} //= uri_unescape_utf8($user); + + $params{algorithm} = lc($params{algorithm}) if $params{algorithm}; + $params{counter} = $self->string_value('HmacOtp-Counter') if $params{type} eq 'hotp'; + + return %params; +} + +sub _otp_secret_params { + my $self = shift; + my $type = shift // return (); + + my $secret_txt = $self->string_value("${type}Otp-Secret"); + my $secret_hex = $self->string_value("${type}Otp-Secret-Hex"); + my $secret_b32 = $self->string_value("${type}Otp-Secret-Base32"); + my $secret_b64 = $self->string_value("${type}Otp-Secret-Base64"); + + my $count = grep { defined } ($secret_txt, $secret_hex, $secret_b32, $secret_b64); + return () if $count == 0; + alert "Found multiple ${type}Otp-Secret strings", count => $count if 1 < $count; + + return (secret => $secret_b32, base32 => 1) if defined $secret_b32; + return (secret => decode_b64($secret_b64)) if defined $secret_b64; + return (secret => pack('H*', $secret_hex)) if defined $secret_hex; + return (secret => encode('UTF-8', $secret_txt)); +} + +sub _hotp_increment_counter { + my $self = shift; + my $counter = shift // $self->string_value('HmacOtp-Counter') || 0; + + looks_like_number($counter) or throw 'HmacOtp-Counter value must be a number', value => $counter; + my $next = $counter + 1; + $self->string('HmacOtp-Counter', $next); + return $next; +} + +############################################################################## + + +sub size { + my $self = shift; + + my $size = 0; + + # tags + $size += length(encode('UTF-8', $self->tags // '')); + + # attributes (strings) + while (my ($key, $string) = each %{$self->strings}) { + next if !defined $string->{value}; + $size += length(encode('UTF-8', $key)) + length(encode('UTF-8', $string->{value} // '')); + } + + # custom data + while (my ($key, $item) = each %{$self->custom_data}) { + next if !defined $item->{value}; + $size += length(encode('UTF-8', $key)) + length(encode('UTF-8', $item->{value} // '')); + } + + # binaries + while (my ($key, $binary) = each %{$self->binaries}) { + next if !defined $binary->{value}; + my $value_len = utf8::is_utf8($binary->{value}) ? length(encode('UTF-8', $binary->{value})) + : length($binary->{value}); + $size += length(encode('UTF-8', $key)) + $value_len; + } + + # autotype associations + for my $association (@{$self->auto_type->{associations} || []}) { + $size += length(encode('UTF-8', $association->{window})) + + length(encode('UTF-8', $association->{keystroke_sequence} // '')); + } + + return $size; +} + +############################################################################## + +sub history { + my $self = shift; + my $entries = $self->{history} //= []; + if (@$entries && !blessed($entries->[0])) { + @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries; + } + assert { !any { !blessed $_ } @$entries }; + return $entries; +} + + +sub history_size { + my $self = shift; + return sum0 map { $_->size } @{$self->history}; +} + + +sub prune_history { + my $self = shift; + my %args = @_; + + my $max_items = $args{max_items} // eval { $self->kdbx->history_max_items } // HISTORY_DEFAULT_MAX_ITEMS; + my $max_size = $args{max_size} // eval { $self->kdbx->history_max_size } // HISTORY_DEFAULT_MAX_SIZE; + my $max_age = $args{max_age} // HISTORY_DEFAULT_MAX_AGE; + + # history is ordered oldest to newest + my $history = $self->history; + + my @removed; + + if (0 <= $max_items && $max_items < @$history) { + push @removed, splice @$history, -$max_items; + } + + if (0 <= $max_size) { + my $current_size = $self->history_size; + while ($max_size < $current_size) { + push @removed, my $entry = shift @$history; + $current_size -= $entry->size; + } + } + + if (0 <= $max_age) { + my $cutoff = gmtime - ($max_age * 86400); + for (my $i = @$history - 1; 0 <= $i; --$i) { + my $entry = $history->[$i]; + next if $cutoff <= $entry->last_modification_time; + push @removed, splice @$history, $i, 1; + } + } + + @removed = sort { $a->last_modification_time <=> $b->last_modification_time } @removed; + return @removed; +} + + +sub add_historical_entry { + my $self = shift; + delete $_->{history} for @_; + push @{$self->{history} //= []}, map { $self->_wrap_entry($_) } @_; +} + + +sub remove_historical_entry { + my $self = shift; + my $entry = shift; + my $history = $self->history; + + my @removed; + for (my $i = @$history - 1; 0 <= $i; --$i) { + my $item = $history->[$i]; + next if Hash::Util::FieldHash::id($entry) != Hash::Util::FieldHash::id($item); + push @removed, splice @{$self->{history}}, $i, 1; + } + return @removed; +} + + +sub current_entry { + my $self = shift; + my $parent = $self->group; + + if ($parent) { + my $id = $self->uuid; + my $entry = first { $id eq $_->uuid } @{$parent->entries}; + return $entry if $entry; + } + + return $self; +} + + +sub is_current { + my $self = shift; + my $current = $self->current_entry; + return Hash::Util::FieldHash::id($self) == Hash::Util::FieldHash::id($current); +} + + +sub is_historical { !$_[0]->is_current } + + +sub remove { + my $self = shift; + my $current = $self->current_entry; + return $self if $current->remove_historical_entry($self); + $self->SUPER::remove(@_); +} + +############################################################################## + + +sub searching_enabled { + my $self = shift; + my $parent = $self->group; + return $parent->effective_enable_searching if $parent; + return true; +} + +sub auto_type_enabled { + my $self = shift; + $self->auto_type->{enabled} = to_bool(shift) if @_; + $self->auto_type->{enabled} //= true; + return false if !$self->auto_type->{enabled}; + return true if !$self->is_connected; + my $parent = $self->group; + return $parent->effective_enable_auto_type if $parent; + return true; +} + +############################################################################## + +sub _signal { + my $self = shift; + my $type = shift; + return $self->SUPER::_signal("entry.$type", @_); +} + +sub _commit { + my $self = shift; + my $orig = shift; + $self->add_historical_entry($orig); + my $time = gmtime; + $self->last_modification_time($time); + $self->last_access_time($time); +} + +sub label { shift->expand_title(@_) } + +### Name of the parent attribute expected to contain the object +sub _parent_container { 'entries' } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Entry - A KDBX database entry + +=head1 VERSION + +version 0.800 + +=head1 DESCRIPTION + +An entry in a KDBX database is a record that can contains strings (also called "fields") and binaries (also +called "files" or "attachments"). Every string and binary has a key or name. There is a default set of strings +that every entry has: + +=over 4 + +=item * + +B<Title> + +=item * + +B<UserName> + +=item * + +B<Password> + +=item * + +B<URL> + +=item * + +B<Notes> + +=back + +Beyond this, you can store any number of other strings and any number of binaries that you can use for +whatever purpose you want. + +There is also some metadata associated with an entry. Each entry in a database is identified uniquely by +a UUID. An entry can also have an icon associated with it, and there are various timestamps. Take a look at +the attributes to see what's available. + +A B<File::KDBX::Entry> is a subclass of L<File::KDBX::Object>. + +=head2 Placeholders + +Entry string and auto-type key sequences can have placeholders or template tags that can be replaced by other +values. Placeholders can appear like C<{PLACEHOLDER}>. For example, a B<URL> string might have a value of +C<http://example.com?user={USERNAME}>. C<{USERNAME}> is a placeholder for the value of the B<UserName> string +of the same entry. If the B<UserName> string had a value of "batman", the B<URL> string would expand to +C<http://example.com?user=batman>. + +Some placeholders take an argument, where the argument follows the tag after a colon but before the closing +brace, like C<{PLACEHOLDER:ARGUMENT}>. + +Placeholders are documented in the L<KeePass Help Center|https://keepass.info/help/base/placeholders.html>. +This software supports many (but not all) of the placeholders documented there. + +=head3 Entry Placeholders + +=over 4 + +=item * + +☑ C<{TITLE}> - B<Title> string + +=item * + +☑ C<{USERNAME}> - B<UserName> string + +=item * + +☑ C<{PASSWORD}> - B<Password> string + +=item * + +☑ C<{NOTES}> - B<Notes> string + +=item * + +☑ C<{URL}> - B<URL> string + +=item * + +☑ C<{URL:SCM}> / C<{URL:SCHEME}> + +=item * + +☑ C<{URL:USERINFO}> + +=item * + +☑ C<{URL:USERNAME}> + +=item * + +☑ C<{URL:PASSWORD}> + +=item * + +☑ C<{URL:HOST}> + +=item * + +☑ C<{URL:PORT}> + +=item * + +☑ C<{URL:PATH}> + +=item * + +☑ C<{URL:QUERY}> + +=item * + +☑ C<{URL:FRAGMENT}> / C<{URL:HASH}> + +=item * + +☑ C<{URL:RMVSCM}> / C<{URL:WITHOUTSCHEME}> + +=item * + +☑ C<{S:Name}> - Custom string where C<Name> is the name or key of the string + +=item * + +☑ C<{UUID}> - Identifier (32 hexidecimal characters) + +=item * + +☑ C<{HMACOTP}> - Generate an HMAC-based one-time password (its counter B<will> be incremented) + +=item * + +☑ C<{TIMEOTP}> - Generate a time-based one-time password + +=item * + +☑ C<{GROUP_NOTES}> - Notes of the parent group + +=item * + +☑ C<{GROUP_PATH}> - Full path of the parent group + +=item * + +☑ C<{GROUP}> - Name of the parent group + +=back + +=head3 Field References + +=over 4 + +=item * + +☑ C<{REF:Wanted@SearchIn:Text}> - See L<File::KDBX/resolve_reference> + +=back + +=head3 File path Placeholders + +=over 4 + +=item * + +☑ C<{APPDIR}> - Program directory path + +=item * + +☑ C<{FIREFOX}> - Path to the Firefox browser executable + +=item * + +☑ C<{GOOGLECHROME}> - Path to the Chrome browser executable + +=item * + +☑ C<{INTERNETEXPLORER}> - Path to the Firefox browser executable + +=item * + +☑ C<{OPERA}> - Path to the Opera browser executable + +=item * + +☑ C<{SAFARI}> - Path to the Safari browser executable + +=item * + +☒ C<{DB_PATH}> - Full file path of the database + +=item * + +☒ C<{DB_DIR}> - Directory path of the database + +=item * + +☒ C<{DB_NAME}> - File name (including extension) of the database + +=item * + +☒ C<{DB_BASENAME}> - File name (excluding extension) of the database + +=item * + +☒ C<{DB_EXT}> - File name extension + +=item * + +☑ C<{ENV_DIRSEP}> - Directory separator + +=item * + +☑ C<{ENV_PROGRAMFILES_X86}> - One of C<%ProgramFiles(x86)%> or C<%ProgramFiles%> + +=back + +=head3 Date and Time Placeholders + +=over 4 + +=item * + +☑ C<{DT_SIMPLE}> - Current local date and time as a sortable string + +=item * + +☑ C<{DT_YEAR}> - Year component of the current local date + +=item * + +☑ C<{DT_MONTH}> - Month component of the current local date + +=item * + +☑ C<{DT_DAY}> - Day component of the current local date + +=item * + +☑ C<{DT_HOUR}> - Hour component of the current local time + +=item * + +☑ C<{DT_MINUTE}> - Minute component of the current local time + +=item * + +☑ C<{DT_SECOND}> - Second component of the current local time + +=item * + +☑ C<{DT_UTC_SIMPLE}> - Current UTC date and time as a sortable string + +=item * + +☑ C<{DT_UTC_YEAR}> - Year component of the current UTC date + +=item * + +☑ C<{DT_UTC_MONTH}> - Month component of the current UTC date + +=item * + +☑ C<{DT_UTC_DAY}> - Day component of the current UTC date + +=item * + +☑ C<{DT_UTC_HOUR}> - Hour component of the current UTC time + +=item * + +☑ C<{DT_UTC_MINUTE}> Minute Year component of the current UTC time + +=item * + +☑ C<{DT_UTC_SECOND}> - Second component of the current UTC time + +=back + +If the current date and time is <2012-07-25 17:05:34>, the "simple" form would be C<20120725170534>. + +=head3 Special Key Placeholders + +Certain placeholders for use in auto-type key sequences are not supported for replacement, but they will +remain as-is so that an auto-type engine (not included) can parse and replace them with the appropriate +virtual key presses. For completeness, here is the list that the KeePass program claims to support: + +C<{TAB}>, C<{ENTER}>, C<{UP}>, C<{DOWN}>, C<{LEFT}>, C<{RIGHT}>, C<{HOME}>, C<{END}>, C<{PGUP}>, C<{PGDN}>, +C<{INSERT}>, C<{DELETE}>, C<{SPACE}> + +C<{BACKSPACE}>, C<{BREAK}>, C<{CAPSLOCK}>, C<{ESC}>, C<{WIN}>, C<{LWIN}>, C<{RWIN}>, C<{APPS}>, C<{HELP}>, +C<{NUMLOCK}>, C<{PRTSC}>, C<{SCROLLLOCK}> + +C<{F1}>, C<{F2}>, C<{F3}>, C<{F4}>, C<{F5}>, C<{F6}>, C<{F7}>, C<{F8}>, C<{F9}>, C<{F10}>, C<{F11}>, C<{F12}>, +C<{F13}>, C<{F14}>, C<{F15}>, C<{F16}> + +C<{ADD}>, C<{SUBTRACT}>, C<{MULTIPLY}>, C<{DIVIDE}>, C<{NUMPAD0}>, C<{NUMPAD1}>, C<{NUMPAD2}>, C<{NUMPAD3}>, +C<{NUMPAD4}>, C<{NUMPAD5}>, C<{NUMPAD6}>, C<{NUMPAD7}>, C<{NUMPAD8}>, C<{NUMPAD9}> + +=head3 Miscellaneous Placeholders + +=over 4 + +=item * + +☒ C<{BASE}> + +=item * + +☒ C<{BASE:SCM}> / C<{BASE:SCHEME}> + +=item * + +☒ C<{BASE:USERINFO}> + +=item * + +☒ C<{BASE:USERNAME}> + +=item * + +☒ C<{BASE:PASSWORD}> + +=item * + +☒ C<{BASE:HOST}> + +=item * + +☒ C<{BASE:PORT}> + +=item * + +☒ C<{BASE:PATH}> + +=item * + +☒ C<{BASE:QUERY}> + +=item * + +☒ C<{BASE:FRAGMENT}> / C<{BASE:HASH}> + +=item * + +☒ C<{BASE:RMVSCM}> / C<{BASE:WITHOUTSCHEME}> + +=item * + +☒ C<{CLIPBOARD-SET:/Text/}> + +=item * + +☒ C<{CLIPBOARD}> + +=item * + +☒ C<{CMD:/CommandLine/Options/}> + +=item * + +☑ C<{C:Comment}> - Comments are simply replaced by nothing + +=item * + +☑ C<{ENV:}> and C<%ENV%> - Environment variables + +=item * + +☒ C<{GROUP_SEL_NOTES}> + +=item * + +☒ C<{GROUP_SEL_PATH}> + +=item * + +☒ C<{GROUP_SEL}> + +=item * + +☒ C<{NEWPASSWORD}> + +=item * + +☒ C<{NEWPASSWORD:/Profile/}> + +=item * + +☒ C<{PASSWORD_ENC}> + +=item * + +☒ C<{PICKCHARS}> + +=item * + +☒ C<{PICKCHARS:Field:Options}> + +=item * + +☒ C<{PICKFIELD}> + +=item * + +☒ C<{T-CONV:/Text/Type/}> + +=item * + +☒ C<{T-REPLACE-RX:/Text/Type/Replace/}> + +=back + +Some of these that remain unimplemented, such as C<{CLIPBOARD}>, cannot be implemented portably. Some of these +I haven't implemented (yet) just because they don't seem very useful. You can create your own placeholder to +augment the list of default supported placeholders or to replace a built-in placeholder handler. To create +a placeholder, just set it in the C<%File::KDBX::PLACEHOLDERS> hash. For example: + + $File::KDBX::PLACEHOLDERS{'MY_PLACEHOLDER'} = sub { + my ($entry) = @_; + ...; + }; + +If the placeholder is expanded in the context of an entry, C<$entry> is the B<File::KDBX::Entry> object in +context. Otherwise it is C<undef>. An entry is in context if, for example, the placeholder is in an entry's +strings or auto-complete key sequences. + + $File::KDBX::PLACEHOLDERS{'MY_PLACEHOLDER:'} = sub { + my ($entry, $arg) = @_; # ^ Notice the colon here + ...; + }; + +If the name of the placeholder ends in a colon, then it is expected to receive an argument. During expansion, +everything after the colon and before the end of the placeholder is passed to your placeholder handler +subroutine. So if the placeholder is C<{MY_PLACEHOLDER:whatever}>, C<$arg> will have the value B<whatever>. + +An argument is required for placeholders than take one. I.e. The placeholder handler won't be called if there +is no argument. If you want a placeholder to support an optional argument, you'll need to set the placeholder +both with and without a colon (or they could be different subroutines): + + $File::KDBX::PLACEHOLDERS{'RAND'} = $File::KDBX::PLACEHOLDERS{'RAND:'} = sub { + (undef, my $arg) = @_; + return defined $arg ? rand($arg) : rand; + }; + +You can also remove placeholder handlers. If you want to disable placeholder expansion entirely, just delete +all the handlers: + + %File::KDBX::PLACEHOLDERS = (); + +=head2 One-time Passwords + +An entry can be configured to generate one-time passwords, both HOTP (HMAC-based) and TOTP (time-based). The +configuration storage isn't completely standardized, but this module supports two predominant configuration +styles: + +=over 4 + +=item * + +L<KeePass 2|https://keepass.info/help/base/placeholders.html#otp> + +=item * + +KeePassXC + +=back + +B<NOTE:> To use this feature, you must install the suggested dependency: + +=over 4 + +=item * + +L<Pass::OTP> + +=back + +To configure TOTP in the KeePassXC style, there is only one string to set: C<otp>. The value should be any +valid otpauth URI. When generating an OTP, all of the relevant OTP properties are parsed from the URI. + +To configure TOTP in the KeePass 2 style, set the following strings: + +=over 4 + +=item * + +C<TimeOtp-Algorithm> - Cryptographic algorithm, one of C<HMAC-SHA-1> (default), C<HMAC-SHA-256> and C<HMAC-SHA-512> + +=item * + +C<TimeOtp-Length> - Number of digits each one-time password is (default: 6, maximum: 8) + +=item * + +C<TimeOtp-Period> - Time-step size in seconds (default: 30) + +=item * + +C<TimeOtp-Secret> - Text string secret, OR + +=item * + +C<TimeOtp-Secret-Hex> - Hexidecimal-encoded secret, OR + +=item * + +C<TimeOtp-Secret-Base32> - Base32-encoded secret (most common), OR + +=item * + +C<TimeOtp-Secret-Base64> - Base64-encoded secret + +=back + +To configure HOTP in the KeePass 2 style, set the following strings: + +=over 4 + +=item * + +C<HmacOtp-Counter> - Counting value in decimal, starts on C<0> by default and increments when L</hmac_otp> is called + +=item * + +C<HmacOtp-Secret> - Text string secret, OR + +=item * + +C<HmacOtp-Secret-Hex> - Hexidecimal-encoded secret, OR + +=item * + +C<HmacOtp-Secret-Base32> - Base32-encoded secret (most common), OR + +=item * + +C<HmacOtp-Secret-Base64> - Base64-encoded secret + +=back + +B<NOTE:> The multiple "Secret" strings are simply a way to store a secret in different formats. Only one of +these should actually be set or an error will be thrown. + +Here's a basic example: + + $entry->string(otp => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer'); + # OR + $entry->string('TimeOtp-Secret-Base32' => 'NBSWY3DP'); + + my $otp = $entry->time_otp; + +=head1 ATTRIBUTES + +=head2 uuid + +128-bit UUID identifying the entry within the database. + +=head2 icon_id + +Integer representing a default icon. See L<File::KDBX::Constants/":icon"> for valid values. + +=head2 custom_icon_uuid + +128-bit UUID identifying a custom icon within the database. + +=head2 foreground_color + +Text color represented as a string of the form C<#000000>. + +=head2 background_color + +Background color represented as a string of the form C<#FFFFFF>. + +=head2 override_url + +TODO + +=head2 tags + +Text string with arbitrary tags which can be used to build a taxonomy. + +=head2 auto_type_enabled + +Whether or not the entry is eligible to be matched for auto-typing. + +=head2 auto_type_obfuscation + +Whether or not to use some kind of obfuscation when sending keystroke sequences to applications. + +=head2 auto_type_default_sequence + +The default auto-type keystroke sequence. + +=head2 auto_type_associations + +An array of window title / keystroke sequence associations. + + { + window => 'Example Window Title', + keystroke_sequence => '{USERNAME}{TAB}{PASSWORD}{ENTER}', + } + +Keystroke sequences can have </Placeholders>, most commonly C<{USERNAME}> and C<{PASSWORD}>. + +=head2 previous_parent_group + +128-bit UUID identifying a group within the database. + +=head2 quality_check + +Boolean indicating whether the entry password should be tested for weakness and show up in reports. + +=head2 strings + +Hash with entry strings, including the standard strings as well as any custom ones. + + { + # Every entry has these five strings: + Title => { value => 'Example Entry' }, + UserName => { value => 'jdoe' }, + Password => { value => 's3cr3t', protect => true }, + URL => { value => 'https://example.com' } + Notes => { value => '' }, + # May also have custom strings: + MySystem => { value => 'The mainframe' }, + } + +There are methods available to provide more convenient access to strings, including L</string>, +L</string_value>, L</expand_string_value> and L</string_peek>. + +=head2 binaries + +Files or attachments. Binaries are similar to strings except they have a value of bytes instead of test +characters. + + { + 'myfile.txt' => { + value => '...', + }, + 'mysecrets.txt' => { + value => '...', + protect => true, + }, + } + +There are methods available to provide more convenient access to binaries, including L</binary> and +L</binary_value>. + +=head2 custom_data + +A set of key-value pairs used to store arbitrary data, usually used by software to keep track of state rather +than by end users (who typically work with the strings and binaries). + +=head2 history + +Array of historical entries. Historical entries are prior versions of the same entry so they all share the +same UUID with the current entry. + +=head2 last_modification_time + +Date and time when the entry was last modified. + +=head2 creation_time + +Date and time when the entry was created. + +=head2 last_access_time + +Date and time when the entry was last accessed. + +=head2 expiry_time + +Date and time when the entry expired or will expire. + +=head2 expires + +Boolean value indicating whether or not an entry is expired. + +=head2 usage_count + +The number of times an entry has been used, which typically means how many times the B<Password> string has +been accessed. + +=head2 location_changed + +Date and time when the entry was last moved to a different parent group. + +=head2 notes + +Alias for the B<Notes> string value. + +=head2 password + +Alias for the B<Password> string value. + +=head2 title + +Alias for the B<Title> string value. + +=head2 url + +Alias for the B<URL> string value. + +=head2 username + +Aliases for the B<UserName> string value. + +=head2 expand_notes + +Shortcut equivalent to C<< ->expand_string_value('Notes') >>. + +=head2 expand_password + +Shortcut equivalent to C<< ->expand_string_value('Password') >>. + +=head2 expand_title + +Shortcut equivalent to C<< ->expand_string_value('Title') >>. + +=head2 expand_url + +Shortcut equivalent to C<< ->expand_string_value('URL') >>. + +=head2 expand_username + +Shortcut equivalent to C<< ->expand_string_value('UserName') >>. + +=head1 METHODS + +=head2 string + + \%string = $entry->string($string_key); + + $entry->string($string_key, \%string); + $entry->string($string_key, %attributes); + $entry->string($string_key, $value); # same as: value => $value + +Get or set a string. Every string has a unique (to the entry) key and flags and so are returned as a hash +structure. For example: + + $string = { + value => 'Password', + protect => true, # optional + }; + +Every string should have a value (but might be C<undef> due to memory protection) and these optional flags +which might exist: + +=over 4 + +=item * + +C<protect> - Whether or not the string value should be memory-protected. + +=back + +=head2 string_value + + $string = $entry->string_value($string_key); + +Access a string value directly. The arguments are the same as for L</string>. Returns C<undef> if the string +is not set or is currently memory-protected. This is just a shortcut for: + + my $string = do { + my $s = $entry->string(...); + defined $s ? $s->{value} : undef; + }; + +=head2 expand_string_value + + $string = $entry->expand_string_value; + +Same as L</string_value> but will substitute placeholders and resolve field references. Any placeholders that +do not expand to values are left as-is. + +See L</Placeholders>. + +Some placeholders (notably field references) require the entry be connected to a database and will throw an +error if it is not. + +=head2 other_strings + + $other = $entry->other_strings; + $other = $entry->other_strings($delimiter); + +Get a concatenation of all non-standard string values. The default delimiter is a newline. This is is useful +for executing queries to search for entities based on the contents of these other strings (if any). + +=head2 string_peek + + $string = $entry->string_peek($string_key); + +Same as L</string_value> but can also retrieve the value from protected-memory if the value is currently +protected. + +=head2 add_auto_type_association + + $entry->add_auto_type_association(\%association); + +Add a new auto-type association to an entry. + +=head2 expand_keystroke_sequence + + $string = $entry->expand_keystroke_sequence($keystroke_sequence); + $string = $entry->expand_keystroke_sequence(\%association); + $string = $entry->expand_keystroke_sequence; # use default auto-type sequence + +Get a keystroke sequence after placeholder expansion. + +=head2 binary + + \%binary = $entry->binary($binary_key); + + $entry->binary($binary_key, \%binary); + $entry->binary($binary_key, %attributes); + $entry->binary($binary_key, $value); # same as: value => $value + +Get or set a binary. Every binary has a unique (to the entry) key and flags and so are returned as a hash +structure. For example: + + $binary = { + value => '...', + protect => true, # optional + }; + +Every binary should have a value (but might be C<undef> due to memory protection) and these optional flags +which might exist: + +=over 4 + +=item * + +C<protect> - Whether or not the binary value should be memory-protected. + +=back + +=head2 binary_value + + $binary = $entry->binary_value($binary_key); + +Access a binary value directly. The arguments are the same as for L</binary>. Returns C<undef> if the binary +is not set or is currently memory-protected. This is just a shortcut for: + + my $binary = do { + my $b = $entry->binary(...); + defined $b ? $b->{value} : undef; + }; + +=head2 hmac_otp + + $otp = $entry->hmac_otp(%options); + +Generate an HMAC-based one-time password, or C<undef> if HOTP is not configured for the entry. The entry's +strings generally must first be unprotected, just like when accessing the password. Valid options are: + +=over 4 + +=item * + +C<counter> - Specify the counter value + +=back + +To configure HOTP, see L</"One-time Passwords">. + +=head2 time_otp + + $otp = $entry->time_otp(%options); + +Generate a time-based one-time password, or C<undef> if TOTP is not configured for the entry. The entry's +strings generally must first be unprotected, just like when accessing the password. Valid options are: + +=over 4 + +=item * + +C<now> - Specify the value for determining the time-step counter + +=back + +To configure TOTP, see L</"One-time Passwords">. + +=head2 hmac_otp_uri + +=head2 time_otp_uri + + $uri_string = $entry->hmac_otp_uri; + $uri_string = $entry->time_otp_uri; + +Get a HOTP or TOTP otpauth URI for the entry, if available. + +To configure OTP, see L</"One-time Passwords">. + +=head2 size + + $size = $entry->size; + +Get the size (in bytes) of an entry. + +B<NOTE:> This is not an exact figure because there is no canonical serialization of an entry. This size should +only be used as a rough estimate for comparison with other entries or to impose data size limitations. + +=head2 history_size + + $size = $entry->history_size; + +Get the size (in bytes) of all historical entries combined. + +=head2 prune_history + + @removed_historical_entries = $entry->prune_history(%options); + +Remove just as many older historical entries as necessary to get under the database limits. The limits are +taken from the connected database (if any) or can be overridden with C<%options>: + +=over 4 + +=item * + +C<max_items> - Maximum number of historical entries to keep (default: 10, no limit: -1) + +=item * + +C<max_size> - Maximum total size (in bytes) of historical entries to keep (default: 6 MiB, no limit: -1) + +=item * + +C<max_age> - Maximum age (in days) of historical entries to keep (default: 365, no limit: -1) + +=back + +=head2 add_historical_entry + + $entry->add_historical_entry($entry); + +Add an entry to the history. + +=head2 remove_historical_entry + + $entry->remove_historical_entry($historical_entry); + +Remove an entry from the history. + +=head2 current_entry + + $current_entry = $entry->current_entry; + +Get an entry's current entry. If the entry itself is current (not historical), itself is returned. + +=head2 is_current + + $bool = $entry->is_current; + +Get whether or not an entry is considered current (i.e. not historical). An entry is current if it is directly +in the parent group's entry list. + +=head2 is_historical + + $bool = $entry->is_historical; + +Get whether or not an entry is considered historical (i.e. not current). + +This is just the inverse of L</is_current>. + +=head2 remove + + $entry = $entry->remove; + +Remove an entry from its parent group. If the entry is historical, remove it from the history of the current +entry. If the entry is current, this behaves the same as L<File::KDBX::Object/remove>. + +=head2 searching_enabled + + $bool = $entry->searching_enabled; + +Get whether or not an entry may show up in search results. This is determine from the entry's parent group's +L<File::KDBX::Group/effective_enable_searching> value. + +Throws if entry has no parent group or if the entry is not connected to a database. + +=for Pod::Coverage auto_type times + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Error.pm b/lib/File/KDBX/Error.pm new file mode 100644 index 0000000..fc182af --- /dev/null +++ b/lib/File/KDBX/Error.pm @@ -0,0 +1,276 @@ +package File::KDBX::Error; +# ABSTRACT: Represents something bad that happened + +use warnings; +use strict; + +use Exporter qw(import); +use Scalar::Util qw(blessed looks_like_number); +use namespace::clean -except => 'import'; + +our $VERSION = '0.800'; # VERSION + +our @EXPORT = qw(alert error throw); + +my $WARNINGS_CATEGORY; +BEGIN { + $WARNINGS_CATEGORY = 'File::KDBX'; + if (warnings->can('register_categories')) { + warnings::register_categories($WARNINGS_CATEGORY); + } + else { + eval qq{package $WARNINGS_CATEGORY; use warnings::register; 1}; ## no critic ProhibitStringyEval + } + + my $debug = $ENV{DEBUG}; + $debug = looks_like_number($debug) ? (0 + $debug) : ($debug ? 1 : 0); + *_DEBUG = $debug == 1 ? sub() { 1 } : + $debug == 2 ? sub() { 2 } : + $debug == 3 ? sub() { 3 } : + $debug == 4 ? sub() { 4 } : sub() { 0 }; +} + +use overload '""' => 'to_string', cmp => '_cmp'; + + +sub new { + my $class = shift; + my %args = @_ % 2 == 0 ? @_ : (_error => shift, @_); + + my $error = delete $args{_error}; + my $e = $error; + $e =~ s/ at \H+ line \d+.*//g; + + my $self = bless { + details => \%args, + error => $e // 'Something happened', + errno => $!, + previous => $@, + trace => do { + require Carp; + local $Carp::CarpInternal{''.__PACKAGE__} = 1; + my $mess = $error =~ /at \H+ line \d+/ ? $error : Carp::longmess($error); + [map { /^\h*(.*?)\.?$/ ? $1 : $_ } split(/\n/, $mess)]; + }, + }, $class; + chomp $self->{error}; + return $self; +} + + +sub error { + my $class = @_ && $_[0] eq __PACKAGE__ ? shift : undef; + my $self = (blessed($_[0]) && $_[0]->isa('File::KDBX::Error')) + ? shift + : $class + ? $class->new(@_) + : __PACKAGE__->new(@_); + return $self; +} + + +sub details { + my $self = shift; + my %args = @_; + my $details = $self->{details} //= {}; + @$details{keys %args} = values %args; + return $details; +} + + + +sub errno { $_[0]->{errno} } +sub previous { $_[0]->{previous} } +sub trace { $_[0]->{trace} // [] } +sub type { $_[0]->details->{type} // '' } + + +sub _cmp { "$_[0]" cmp "$_[1]" } + +sub to_string { + my $self = shift; + my $msg = "$self->{trace}[0]"; + $msg .= '.' if $msg !~ /[\.\!\?]$/; + if (2 <= _DEBUG) { + require Data::Dumper; + local $Data::Dumper::Indent = 1; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Terse = 1; + local $Data::Dumper::Trailingcomma = 1; + local $Data::Dumper::Useqq = 1; + $msg .= "\n" . Data::Dumper::Dumper $self; + } + $msg .= "\n" if $msg !~ /\n$/; + return $msg; +} + + +sub throw { + my $self = error(@_); + die $self; +} + + +sub warn { + return if !($File::KDBX::WARNINGS // 1); + + my $self = error(@_); + + # Use die and warn directly instead of warnings::warnif because the latter only provides the stringified + # error to the warning signal handler (perl 5.34). Maybe that's a warnings.pm bug? + + if (my $fatal = warnings->can('fatal_enabled_at_level')) { + my $blame = _find_blame_frame(); + die $self if $fatal->($WARNINGS_CATEGORY, $blame); + } + + if (my $enabled = warnings->can('enabled_at_level')) { + my $blame = _find_blame_frame(); + warn $self if $enabled->($WARNINGS_CATEGORY, $blame); + } + elsif ($enabled = warnings->can('enabled')) { + warn $self if $enabled->($WARNINGS_CATEGORY); + } + else { + warn $self; + } + return $self; +} + + +sub alert { goto &warn } + +sub _find_blame_frame { + my $frame = 1; + while (1) { + my ($package) = caller($frame); + last if !$package; + return $frame - 1 if $package !~ /^\Q$WARNINGS_CATEGORY\E/; + $frame++; + } + return 0; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Error - Represents something bad that happened + +=head1 VERSION + +version 0.800 + +=head1 ATTRIBUTES + +=head2 details + + \%details = $error->details; + +Get the error details. + +=head2 errno + +Get the value of C<errno> when the exception was created. + +=head2 previous + +Get the value of C<$@> (i.e. latest exception) at the time the exception was created. + +=head2 trace + +Get a stack trace indicating where in the code the exception was created. + +=head2 type + +Get the exception type, if any. + +=head1 METHODS + +=head2 new + + $error = File::KDBX::Error->new($message, %details); + +Construct a new error. + +=head2 error + + $error = error($error); + $error = error($message, %details); + $error = File::KDBX::Error->error($error); + $error = File::KDBX::Error->error($message, %details); + +Wrap a thing to make it an error object. If the thing is already an error, it gets returned. Otherwise what is +passed will be forwarded to L</new> to create a new error object. + +This can be convenient for error handling when you're not sure what the exception is but you want to treat it +as a B<File::KDBX::Error>. Example: + + eval { ... }; + if (my $error = error(@_)) { + if ($error->type eq 'key.missing') { + handle_missing_key($error); + } + else { + handle_other_error($error); + } + } + +=head2 to_string + + $message = $error->to_string; + $message = "$error"; + +Stringify an error. + +This does not contain a stack trace, but you can set the C<DEBUG> environment variable to at least 2 to +stringify the whole error object. + +=head2 throw + + File::KDBX::Error::throw($message, %details); + $error->throw; + +Throw an error. + +=head2 warn + + File::KDBX::Error::warn($message, %details); + $error->warn; + +Log a warning. + +=head2 alert + + alert $error; + +Importable alias for L</warn>. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Group.pm b/lib/File/KDBX/Group.pm new file mode 100644 index 0000000..d0bd9d7 --- /dev/null +++ b/lib/File/KDBX/Group.pm @@ -0,0 +1,721 @@ +package File::KDBX::Group; +# ABSTRACT: A KDBX database group + +use warnings; +use strict; + +use Devel::GlobalDestruction; +use File::KDBX::Constants qw(:bool :icon :iteration); +use File::KDBX::Error; +use File::KDBX::Iterator; +use File::KDBX::Util qw(:assert :class :coercion generate_uuid); +use Hash::Util::FieldHash; +use List::Util qw(any sum0); +use Ref::Util qw(is_coderef is_ref); +use Scalar::Util qw(blessed); +use Time::Piece; +use boolean; +use namespace::clean; + +extends 'File::KDBX::Object'; + +our $VERSION = '0.800'; # VERSION + + +# has uuid => sub { generate_uuid(printable => 1) }; +has name => '', coerce => \&to_string; +has notes => '', coerce => \&to_string; +has tags => '', coerce => \&to_string; +has icon_id => ICON_FOLDER, coerce => \&to_icon_constant; +has custom_icon_uuid => undef, coerce => \&to_uuid; +has is_expanded => false, coerce => \&to_bool; +has default_auto_type_sequence => '', coerce => \&to_string; +has enable_auto_type => undef, coerce => \&to_tristate; +has enable_searching => undef, coerce => \&to_tristate; +has last_top_visible_entry => undef, coerce => \&to_uuid; +# has custom_data => {}; +has previous_parent_group => undef, coerce => \&to_uuid; +# has entries => []; +# has groups => []; +has times => {}; + +has last_modification_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has creation_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has last_access_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has expiry_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has expires => false, store => 'times', coerce => \&to_bool; +has usage_count => 0, store => 'times', coerce => \&to_number; +has location_changed => sub { gmtime }, store => 'times', coerce => \&to_time; + +my @ATTRS = qw(uuid custom_data entries groups); +sub _set_nonlazy_attributes { + my $self = shift; + $self->$_ for @ATTRS, list_attributes(ref $self); +} + +sub uuid { + my $self = shift; + if (@_ || !defined $self->{uuid}) { + my %args = @_ % 2 == 1 ? (uuid => shift, @_) : @_; + my $old_uuid = $self->{uuid}; + my $uuid = $self->{uuid} = delete $args{uuid} // generate_uuid; + $self->_signal('uuid.changed', $uuid, $old_uuid) if defined $old_uuid; + } + $self->{uuid}; +} + +############################################################################## + + +sub entries { + my $self = shift; + my $entries = $self->{entries} //= []; + if (@$entries && !blessed($entries->[0])) { + @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries; + } + assert { !any { !blessed $_ } @$entries }; + return $entries; +} + + +sub entries_deeply { + my $self = shift; + my %args = @_; + + my $searching = delete $args{searching}; + my $auto_type = delete $args{auto_type}; + my $history = delete $args{history}; + + my $groups = $self->groups_deeply(%args); + my @entries; + + return File::KDBX::Iterator->new(sub { + if (!@entries) { + while (my $group = $groups->next) { + next if $searching && !$group->effective_enable_searching; + next if $auto_type && !$group->effective_enable_auto_type; + @entries = @{$group->entries}; + @entries = grep { $_->auto_type->{enabled} } @entries if $auto_type; + @entries = map { ($_, @{$_->history}) } @entries if $history; + last if @entries; + } + } + shift @entries; + }); +} + + +sub add_entry { + my $self = shift; + my $entry = @_ % 2 == 1 ? shift : undef; + my %args = @_; + + my $kdbx = delete $args{kdbx} // eval { $self->kdbx }; + + $entry = $self->_wrap_entry($entry // [%args]); + $entry->uuid; + $entry->kdbx($kdbx) if $kdbx; + + push @{$self->{entries} ||= []}, $entry->remove; + return $entry->_set_group($self)->_signal('added', $self); +} + + +sub remove_entry { + my $self = shift; + my $uuid = is_ref($_[0]) ? $self->_wrap_entry(shift)->uuid : shift; + my %args = @_; + my $objects = $self->{entries}; + for (my $i = 0; $i < @$objects; ++$i) { + my $object = $objects->[$i]; + next if $uuid ne $object->uuid; + $object->_set_group(undef); + $object->_signal('removed') if $args{signal} // 1; + return splice @$objects, $i, 1; + } +} + +############################################################################## + + +sub groups { + my $self = shift; + my $groups = $self->{groups} //= []; + if (@$groups && !blessed($groups->[0])) { + @$groups = map { $self->_wrap_group($_, $self->kdbx) } @$groups; + } + assert { !any { !blessed $_ } @$groups }; + return $groups; +} + + +sub groups_deeply { + my $self = shift; + my %args = @_; + + my @groups = ($args{inclusive} // 1) ? $self : @{$self->groups}; + my $algo = lc($args{algorithm} || 'ids'); + + if ($algo eq ITERATION_DFS) { + my %visited; + return File::KDBX::Iterator->new(sub { + my $next = shift @groups or return; + if (!$visited{Hash::Util::FieldHash::id($next)}++) { + while (my @children = @{$next->groups}) { + unshift @groups, @children, $next; + $next = shift @groups; + $visited{Hash::Util::FieldHash::id($next)}++; + } + } + $next; + }); + } + elsif ($algo eq ITERATION_BFS) { + return File::KDBX::Iterator->new(sub { + my $next = shift @groups or return; + push @groups, @{$next->groups}; + $next; + }); + } + return File::KDBX::Iterator->new(sub { + my $next = shift @groups or return; + unshift @groups, @{$next->groups}; + $next; + }); +} + +sub _kpx_groups { shift->groups(@_) } + + +sub add_group { + my $self = shift; + my $group = @_ % 2 == 1 ? shift : undef; + my %args = @_; + + my $kdbx = delete $args{kdbx} // eval { $self->kdbx }; + + $group = $self->_wrap_group($group // [%args]); + $group->uuid; + $group->kdbx($kdbx) if $kdbx; + + push @{$self->{groups} ||= []}, $group->remove; + return $group->_set_group($self)->_signal('added', $self); +} + + +sub remove_group { + my $self = shift; + my $uuid = is_ref($_[0]) ? $self->_wrap_group(shift)->uuid : shift; + my %args = @_; + my $objects = $self->{groups}; + for (my $i = 0; $i < @$objects; ++$i) { + my $object = $objects->[$i]; + next if $uuid ne $object->uuid; + $object->_set_group(undef); + $object->_signal('removed') if $args{signal} // 1; + return splice @$objects, $i, 1; + } +} + +############################################################################## + + +sub objects_deeply { + my $self = shift; + my %args = @_; + + my $searching = delete $args{searching}; + my $auto_type = delete $args{auto_type}; + my $history = delete $args{history}; + + my $groups = $self->groups_deeply(%args); + my @entries; + + return File::KDBX::Iterator->new(sub { + if (!@entries) { + while (my $group = $groups->next) { + next if $searching && !$group->effective_enable_searching; + next if $auto_type && !$group->effective_enable_auto_type; + @entries = @{$group->entries}; + @entries = grep { $_->auto_type->{enabled} } @entries if $auto_type; + @entries = map { ($_, @{$_->history}) } @entries if $history; + return $group; + } + } + shift @entries; + }); +} + + +sub add_object { + my $self = shift; + my $obj = shift; + if ($obj->isa('File::KDBX::Entry')) { + $self->add_entry($obj); + } + elsif ($obj->isa('File::KDBX::Group')) { + $self->add_group($obj); + } +} + + +sub remove_object { + my $self = shift; + my $object = shift; + my $blessed = blessed($object); + return $self->remove_group($object, @_) if $blessed && $object->isa('File::KDBX::Group'); + return $self->remove_entry($object, @_) if $blessed && $object->isa('File::KDBX::Entry'); + return $self->remove_group($object, @_) || $self->remove_entry($object, @_); +} + +############################################################################## + + +sub effective_default_auto_type_sequence { + my $self = shift; + my $sequence = $self->default_auto_type_sequence; + return $sequence if defined $sequence; + + my $parent = $self->group or return '{USERNAME}{TAB}{PASSWORD}{ENTER}'; + return $parent->effective_default_auto_type_sequence; +} + + +sub effective_enable_auto_type { + my $self = shift; + my $enabled = $self->enable_auto_type; + return $enabled if defined $enabled; + + my $parent = $self->group or return true; + return $parent->effective_enable_auto_type; +} + + +sub effective_enable_searching { + my $self = shift; + my $enabled = $self->enable_searching; + return $enabled if defined $enabled; + + my $parent = $self->group or return true; + return $parent->effective_enable_searching; +} + +############################################################################## + + +sub is_empty { + my $self = shift; + return @{$self->groups} == 0 && @{$self->entries} == 0; +} + + +sub is_root { + my $self = shift; + my $kdbx = eval { $self->kdbx } or return FALSE; + return Hash::Util::FieldHash::id($kdbx->root) == Hash::Util::FieldHash::id($self); +} + + +sub is_recycle_bin { + my $self = shift; + my $kdbx = eval { $self->kdbx } or return FALSE; + my $group = $kdbx->recycle_bin; + return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self); +} + + +sub is_entry_templates { + my $self = shift; + my $kdbx = eval { $self->kdbx } or return FALSE; + my $group = $kdbx->entry_templates; + return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self); +} + + +sub is_last_selected { + my $self = shift; + my $kdbx = eval { $self->kdbx } or return FALSE; + my $group = $kdbx->last_selected; + return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self); +} + + +sub is_last_top_visible { + my $self = shift; + my $kdbx = eval { $self->kdbx } or return FALSE; + my $group = $kdbx->last_top_visible; + return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self); +} + + +sub path { + my $self = shift; + return $self->name if $self->is_root; + my $lineage = $self->lineage or return; + my @parts = (@$lineage, $self); + shift @parts; + return join('.', map { $_->name } @parts); +} + + +sub size { + my $self = shift; + return sum0 map { $_->size } @{$self->groups}, @{$self->entries}; +} + + +sub depth { $_[0]->is_root ? 0 : (scalar @{$_[0]->lineage || []} || -1) } + +sub _signal { + my $self = shift; + my $type = shift; + return $self->SUPER::_signal("group.$type", @_); +} + +sub _commit { + my $self = shift; + my $time = gmtime; + $self->last_modification_time($time); + $self->last_access_time($time); +} + +sub label { shift->name(@_) } + +### Name of the parent attribute expected to contain the object +sub _parent_container { 'groups' } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Group - A KDBX database group + +=head1 VERSION + +version 0.800 + +=head1 DESCRIPTION + +A group in a KDBX database is a type of object that can contain entries and other groups. + +There is also some metadata associated with a group. Each group in a database is identified uniquely by +a UUID. An entry can also have an icon associated with it, and there are various timestamps. Take a look at +the attributes to see what's available. + +=head1 ATTRIBUTES + +=head2 uuid + +128-bit UUID identifying the group within the database. + +=head2 name + +The human-readable name of the group. + +=head2 notes + +Free form text string associated with the group. + +=head2 tags + +Text string with arbitrary tags which can be used to build a taxonomy. + +=head2 icon_id + +Integer representing a default icon. See L<File::KDBX::Constants/":icon"> for valid values. + +=head2 custom_icon_uuid + +128-bit UUID identifying a custom icon within the database. + +=head2 is_expanded + +Whether or not subgroups are visible when listed for user selection. + +=head2 default_auto_type_sequence + +The default auto-type keystroke sequence, inheritable by entries and subgroups. + +=head2 enable_auto_type + +Whether or not the entry is eligible to be matched for auto-typing, inheritable by entries and subgroups. + +=head2 enable_searching + +Whether or not entries within the group can show up in search results, inheritable by subgroups. + +=head2 last_top_visible_entry + +The UUID of the entry visible at the top of the list. + +=head2 custom_data + +A set of key-value pairs used to store arbitrary data, usually used by software to keep track of state rather +than by end users (who typically work with the strings and binaries). + +=head2 previous_parent_group + +128-bit UUID identifying a group within the database. + +=head2 entries + +Array of entries contained within the group. + +=head2 groups + +Array of subgroups contained within the group. + +=head2 last_modification_time + +Date and time when the entry was last modified. + +=head2 creation_time + +Date and time when the entry was created. + +=head2 last_access_time + +Date and time when the entry was last accessed. + +=head2 expiry_time + +Date and time when the entry expired or will expire. + +=head2 expires + +Boolean value indicating whether or not an entry is expired. + +=head2 usage_count + +TODO + +=head2 location_changed + +Date and time when the entry was last moved to a different parent group. + +=head1 METHODS + +=head2 entries + + \@entries = $group->entries; + +Get an array of direct entries within a group. + +=head2 entries_deeply + + \&iterator = $kdbx->entries_deeply(%options); + +Get an L<File::KDBX::Iterator> over I<entries> within a group. Supports the same options as L</groups>, +plus some new ones: + +=over 4 + +=item * + +C<auto_type> - Only include entries with auto-type enabled (default: false, include all) + +=item * + +C<searching> - Only include entries within groups with searching enabled (default: false, include all) + +=item * + +C<history> - Also include historical entries (default: false, include only current entries) + +=back + +=head2 add_entry + + $entry = $group->add_entry($entry); + $entry = $group->add_entry(%entry_attributes); + +Add an entry to a group. If C<$entry> already has a parent group, it will be removed from that group before +being added to C<$group>. + +=head2 remove_entry + + $entry = $group->remove_entry($entry); + $entry = $group->remove_entry($entry_uuid); + +Remove an entry from a group's array of entries. Returns the entry removed or C<undef> if nothing removed. + +=head2 groups + + \@groups = $group->groups; + +Get an array of direct subgroups within a group. + +=head2 groups_deeply + + \&iterator = $group->groups_deeply(%options); + +Get an L<File::KDBX::Iterator> over I<groups> within a groups, deeply. Options: + +=over 4 + +=item * + +C<inclusive> - Include C<$group> itself in the results (default: true) + +=item * + +C<algorithm> - Search algorithm, one of C<ids>, C<bfs> or C<dfs> (default: C<ids>) + +=back + +=head2 add_group + + $new_group = $group->add_group($new_group); + $new_group = $group->add_group(%group_attributes); + +Add a group to a group. If C<$new_group> already has a parent group, it will be removed from that group before +being added to C<$group>. + +=head2 remove_group + + $removed_group = $group->remove_group($group); + $removed_group = $group->remove_group($group_uuid); + +Remove a group from a group's array of subgroups. Returns the group removed or C<undef> if nothing removed. + +=head2 objects_deeply + + \&iterator = $groups->objects_deeply(%options); + +Get an L<File::KDBX::Iterator> over I<objects> within a group, deeply. Groups and entries are considered +objects, so this is essentially a combination of L</groups> and L</entries>. This won't often be useful, but +it can be convenient for maintenance tasks. This method takes the same options as L</groups> and L</entries>. + +=head2 add_object + + $new_entry = $group->add_object($new_entry); + $new_group = $group->add_object($new_group); + +Add an object (either a L<File::KDBX::Entry> or a L<File::KDBX::Group>) to a group. This is the generic +equivalent of the object forms of L</add_entry> and L</add_group>. + +=head2 remove_object + + $group->remove_object($entry); + $group->remove_object($group); + +Remove an object (either a L<File::KDBX::Entry> or a L<File::KDBX::Group>) from a group. This is the generic +equivalent of the object forms of L</remove_entry> and L</remove_group>. + +=head2 effective_default_auto_type_sequence + + $text = $group->effective_default_auto_type_sequence; + +Get the value of L</default_auto_type_sequence>, if set, or get the inherited effective default auto-type +sequence of the parent. + +=head2 effective_enable_auto_type + + $text = $group->effective_enable_auto_type; + +Get the value of L</enable_auto_type>, if set, or get the inherited effective auto-type enabled value of the +parent. + +=head2 effective_enable_searching + + $text = $group->effective_enable_searching; + +Get the value of L</enable_searching>, if set, or get the inherited effective searching enabled value of the +parent. + +=head2 is_empty + + $bool = $group->is_empty; + +Get whether or not the group is empty (has no subgroups or entries). + +=head2 is_root + + $bool = $group->is_root; + +Determine if a group is the root group of its connected database. + +=head2 is_recycle_bin + + $bool = $group->is_recycle_bin; + +Get whether or not a group is the recycle bin of its connected database. + +=head2 is_entry_templates + + $bool = $group->is_entry_templates; + +Get whether or not a group is the group containing entry template of its connected database. + +=head2 is_last_selected + + $bool = $group->is_last_selected; + +Get whether or not a group is the prior selected group of its connected database. + +=head2 is_last_top_visible + + $bool = $group->is_last_top_visible; + +Get whether or not a group is the latest top visible group of its connected database. + +=head2 path + + $string = $group->path; + +Get a string representation of a group's lineage. This is used as the substitution value for the +C<{GROUP_PATH}> placeholder. See L<File::KDBX::Entry/Placeholders>. + +For a root group, the path is simply the name of the group. For deeper groups, the path is a period-separated +sequence of group names between the root group and C<$group>, including C<$group> but I<not> the root group. +In other words, paths of deeper groups leave the root group name out. + + Database + -> Root # path is "Root" + -> Foo # path is "Foo" + -> Bar # path is "Foo.Bar" + +Yeah, it doesn't make much sense to me, either, but this matches the behavior of KeePass. + +=head2 size + + $size = $group->size; + +Get the size (in bytes) of a group, including the size of all subroups and entries, if any. + +=head2 depth + + $depth = $group->depth; + +Get the depth of a group within a database. The root group is at depth 0, its direct children are at depth 1, +etc. A group not in a database tree structure returns a depth of -1. + +=for Pod::Coverage times + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/IO.pm b/lib/File/KDBX/IO.pm new file mode 100644 index 0000000..3239a2c --- /dev/null +++ b/lib/File/KDBX/IO.pm @@ -0,0 +1,461 @@ +package File::KDBX::IO; +# ABSTRACT: Base IO class for KDBX-related streams + +use warnings; +use strict; + +use Devel::GlobalDestruction; +use File::KDBX::Constants qw(:bool); +use File::KDBX::Util qw(:class :empty); +use List::Util qw(sum0); +use Ref::Util qw(is_blessed_ref is_ref is_scalarref); +use Symbol qw(gensym); +use namespace::clean; + +extends 'IO::Handle'; + +our $VERSION = '0.800'; # VERSION + +sub _croak { require Carp; goto &Carp::croak } + +my %ATTRS = ( + _append_output => 0, + _buffer_in => sub { [] }, + _buffer_out => sub { [] }, + _error => undef, + _fh => undef, + _mode => '', +); +while (my ($attr, $default) = each %ATTRS) { + no strict 'refs'; ## no critic (ProhibitNoStrict) + *$attr = sub { + my $self = shift; + *$self->{$attr} = shift if @_; + *$self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default; + }; +} + +sub new { + my $class = shift || (caller)[0]; + my $self = bless gensym, ref($class) || $class; + tie *$self, $self if 5.005 <= $]; + return $self; +} + +sub DESTROY { + return if in_global_destruction; + local ($., $@, $!, $^E, $?); + my $self = shift; + $self->close; +} + +sub close { + my $self = shift; + my $fh = $self->_fh // return TRUE; + $self->_POPPED($fh); + $self->_fh(undef); + return $fh->close; +} +sub eof { + my $self = shift; + return FALSE if @{$self->_buffer_in}; + my $fh = $self->_fh // return TRUE; + local *$self->{_error} = *$self->{_error}; + my $char = $self->getc || return TRUE; + $self->ungetc($char); +} +sub read { shift->sysread(@_) } +sub print { + my $self = shift; + for my $buf (@_) { + return FALSE if !$self->write($buf, length($buf)); + } + return TRUE; +} +sub printf { shift->print(sprintf(@_)) } +sub say { shift->print(@_, "\n") } +sub getc { my $c; (shift->read($c, 1) // 0) == 1 ? $c : undef } +sub sysread { + my $self = shift; + my ($out, $len, $offset) = @_; + $out = \$_[0] if !is_scalarref($out); + $offset //= 0; + + $self->_mode('r') if !$self->_mode; + + my $fh = $self->_fh or return 0; + return 0 if defined $len && $len == 0; + + my $append = $self->_append_output; + if (!$append) { + if (!$offset) { + $$out = ''; + } + else { + if (length($$out) < $offset) { + $$out .= "\0" x ($offset - length($$out)); + } + else { + substr($$out, $offset) = ''; + } + } + } + elsif (!defined $$out) { + $$out = ''; + } + + $len ||= 0; + + my $buffer = $self->_buffer_in; + my $buffer_len = $self->_buffer_in_length; + + if (!$len && !$offset) { + if (@$buffer) { + my $blen = length($buffer->[0]); + if ($append) { + $$out .= shift @$buffer; + } + else { + $$out = shift @$buffer; + } + return $blen; + } + else { + my $fill = $self->_FILL($fh) or return 0; + if ($append) { + $$out .= $fill; + } + else { + $$out = $fill; + } + return length($fill); + } + } + + while ($buffer_len < $len) { + my $fill = $self->_FILL($fh); + last if empty $fill; + $self->_buffer_in_add($fill); + $buffer_len += length($fill); + } + + my $read_len = 0; + while ($read_len < $len && @$buffer) { + my $wanted = $len - $read_len; + my $read = shift @$buffer; + if ($wanted < length($read)) { + $$out .= substr($read, 0, $wanted, ''); + unshift @$buffer, $read; + $read_len += $wanted; + } + else { + $$out .= $read; + $read_len += length($read); + } + } + + return $read_len; +} +sub syswrite { + my ($self, $buf, $len, $offset) = @_; + $len //= length($buf); + $offset //= 0; + + $self->_mode('w') if !$self->_mode; + + return $self->_WRITE(substr($buf, $offset, $len), $self->_fh); +} + +sub autoflush { + my $self = shift; + my $fh = $self->_fh // return FALSE; + return $fh->autoflush(@_); +} + +sub opened { + my $self = shift; + my $fh = $self->_fh // return FALSE; + return TRUE; +} +sub getline { + my $self = shift; + + if (!defined $/) { # SLURP + local *$self->{_append_output} = 1; + my $data; + 1 while 0 < $self->read($data); + return $data; + } + elsif (is_scalarref($/) && ${$/} =~ /^\d+$/ && 0 < ${$/}) { + # RECORD MODE + goto &_not_implemented; + } + elsif (length $/ == 0) { + # PARAGRAPH MODE + goto &_not_implemented; + } + else { + # LINE MODE + goto &_not_implemented; + } +} +sub getlines { + my $self = shift; + wantarray or _croak 'Must call getlines in list context'; + my @lines; + while (defined (my $line = $self->getline)) { + push @lines, $line; + } + return @lines; +} +sub ungetc { + my ($self, $ord) = @_; + unshift @{$self->_buffer_in}, chr($ord); + return; +} +sub write { + my ($self, $buf, $len, $offset) = @_; + return $self->syswrite($buf, $len, $offset) == $len; +} +sub error { + my $self = shift; + return !!$self->_error; +} +sub clearerr { + my $self = shift; + my $fh = $self->_fh // return -1; + $self->_error(undef); + return; +} +sub sync { + my $self = shift; + my $fh = $self->_fh // return undef; + return $fh->sync; +} +sub flush { + my $self = shift; + my $fh = $self->_fh // return undef; + $self->_FLUSH($fh); + return $fh->flush; +} +sub printflush { + my $self = shift; + my $orig = $self->autoflush; + my $r = $self->print(@_); + $self->autoflush($orig); + return $r; +} +sub blocking { + my $self = shift; + my $fh = $self->_fh // return TRUE; + return $fh->blocking(@_); +} + +sub format_write { goto &_not_implemented } +sub new_from_fd { goto &_not_implemented } +sub fcntl { goto &_not_implemented } +sub fileno { goto &_not_implemented } +sub ioctl { goto &_not_implemented } +sub stat { goto &_not_implemented } +sub truncate { goto &_not_implemented } +sub format_page_number { goto &_not_implemented } +sub format_lines_per_page { goto &_not_implemented } +sub format_lines_left { goto &_not_implemented } +sub format_name { goto &_not_implemented } +sub format_top_name { goto &_not_implemented } +sub input_line_number { goto &_not_implemented } +sub fdopen { goto &_not_implemented } +sub untaint { goto &_not_implemented } + +############################################################################## + +sub _buffer_in_add { push @{shift->_buffer_in}, @_ } +sub _buffer_in_length { sum0 map { length($_) } @{shift->_buffer_in} } + +sub _buffer_out_add { push @{shift->_buffer_out}, @_ } +sub _buffer_out_length { sum0 map { length($_) } @{shift->_buffer_out} } + +sub _not_implemented { _croak 'Operation not supported' } + +############################################################################## + +sub TIEHANDLE { + return $_[0] if is_blessed_ref($_[0]); + die 'wat'; +} + +sub UNTIE { + my $self = shift; +} + +sub READLINE { + goto &getlines if wantarray; + goto &getline; +} + +sub binmode { 1 } + +{ + no warnings 'once'; + + *READ = \&read; + # *READLINE = \&getline; + *GETC = \&getc; + *FILENO = \&fileno; + *PRINT = \&print; + *PRINTF = \&printf; + *WRITE = \&syswrite; + # *SEEK = \&seek; + # *TELL = \&tell; + *EOF = \&eof; + *CLOSE = \&close; + *BINMODE = \&binmode; +} + +sub _FILL { die 'Not implemented' } + +############################################################################## + +if ($ENV{DEBUG_IO}) { + my %debug = (level => 0); + for my $method (qw{ + new + new_from_fd + close + eof + fcntl + fileno + format_write + getc + ioctl + read + print + printf + say + stat + sysread + syswrite + truncate + + autoflush + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + input_line_number + + fdopen + opened + getline + getlines + ungetc + write + error + clearerr + sync + flush + printflush + blocking + + untaint + }) { + no strict 'refs'; ## no critic (ProhibitNoStrict) + no warnings 'redefine'; + my $orig = *$method{CODE}; + *$method = sub { + local $debug{level} = $debug{level} + 2; + my $indented_method = (' ' x $debug{level}) . $method; + my $self = shift; + print STDERR sprintf('%-20s -> %s (%s)', $indented_method, $self, + join(', ', map { defined $_ ? substr($_, 0, 16) : 'undef' } @_)), "\n"; + my $r = $orig->($self, @_) // 'undef'; + print STDERR sprintf('%-20s <- %s [%s]', $indented_method, $self, $r), "\n"; + return $r; + }; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::IO - Base IO class for KDBX-related streams + +=head1 VERSION + +version 0.800 + +=head1 DESCRIPTION + +This is a L<IO::Handle> subclass which provides self-tying and buffering. It currently provides an interface +for subclasses that is similar to L<PerlIO::via>, but this is subject to change. Don't depend on this outside +of the L<File::KDBX> distribution. Currently-available subclasses: + +=over 4 + +=item * + +L<File::KDBX::IO::Crypt> + +=item * + +L<File::KDBX::IO::HashBlock> + +=item * + +L<File::KDBX::IO::HmacBlock> + +=back + +=for Pod::Coverage autoflush +binmode +close +eof +fcntl +fileno +format_lines_left +format_lines_per_page +format_name +format_page_number +format_top_name +format_write +getc +input_line_number +ioctl +print +printf +read +say +stat +sysread +syswrite +truncate + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/IO/Crypt.pm b/lib/File/KDBX/IO/Crypt.pm new file mode 100644 index 0000000..44670e8 --- /dev/null +++ b/lib/File/KDBX/IO/Crypt.pm @@ -0,0 +1,200 @@ +package File::KDBX::IO::Crypt; +# ABSTRACT: Encrypter/decrypter IO handle + +use warnings; +use strict; + +use Errno; +use File::KDBX::Error; +use File::KDBX::Util qw(:class :empty); +use namespace::clean; + +extends 'File::KDBX::IO'; + +our $VERSION = '0.800'; # VERSION +our $BUFFER_SIZE = 16384; +our $ERROR; + + +my %ATTRS = ( + cipher => undef, +); +while (my ($attr, $default) = each %ATTRS) { + no strict 'refs'; ## no critic (ProhibitNoStrict) + *$attr = sub { + my $self = shift; + *$self->{$attr} = shift if @_; + *$self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default; + }; +} + + +sub new { + my $class = shift; + my %args = @_ % 2 == 1 ? (fh => shift, @_) : @_; + my $self = $class->SUPER::new; + $self->_fh($args{fh}) or throw 'IO handle required'; + $self->cipher($args{cipher}) or throw 'Cipher required'; + return $self; +} + +sub _FILL { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n"; + my $cipher = $self->cipher or return; + + $fh->read(my $buf = '', $BUFFER_SIZE); + if (0 < length($buf)) { + my $plaintext = eval { $cipher->decrypt($buf) }; + if (my $err = $@) { + $self->_set_error($err); + return; + } + return $plaintext if 0 < length($plaintext); + } + + # finish + my $plaintext = eval { $cipher->finish }; + if (my $err = $@) { + $self->_set_error($err); + return; + } + $self->cipher(undef); + return $plaintext; +} + +sub _WRITE { + my ($self, $buf, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n"; + my $cipher = $self->cipher or return 0; + + my $new_data = eval { $cipher->encrypt($buf) } || ''; + if (my $err = $@) { + $self->_set_error($err); + return 0; + } + $self->_buffer_out_add($new_data) if nonempty $new_data; + return length($buf); +} + +sub _POPPED { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n"; + return if $self->_mode ne 'w'; + my $cipher = $self->cipher or return; + + my $new_data = eval { $cipher->finish } || ''; + if (my $err = $@) { + $self->_set_error($err); + return; + } + $self->_buffer_out_add($new_data) if nonempty $new_data; + + $self->cipher(undef); + $self->_FLUSH($fh); +} + +sub _FLUSH { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n"; + return if $self->_mode ne 'w'; + + my $buffer = $self->_buffer_out; + while (@$buffer) { + my $read = shift @$buffer; + next if empty $read; + $fh->print($read) or return -1; + } + return 0; +} + +sub _set_error { + my $self = shift; + $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n"; + if (exists &Errno::EPROTO) { + $! = &Errno::EPROTO; + } + elsif (exists &Errno::EIO) { + $! = &Errno::EIO; + } + $self->cipher(undef); + $self->_error($ERROR = File::KDBX::Error->new(@_)); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::IO::Crypt - Encrypter/decrypter IO handle + +=head1 VERSION + +version 0.800 + +=head1 SYNOPSIS + + use File::KDBX::IO::Crypt; + use File::KDBX::Cipher; + + my $cipher = File::KDBX::Cipher->new(...); + + open(my $out_fh, '>:raw', 'ciphertext.bin'); + $out_fh = File::KDBX::IO::Crypt->new($out_fh, cipher => $cipher); + + print $out_fh $plaintext; + + close($out_fh); + + open(my $in_fh, '<:raw', 'ciphertext.bin'); + $in_fh = File::KDBX::IO::Crypt->new($in_fh, cipher => $cipher); + + my $plaintext = do { local $/; <$in_fh> ); + + close($in_fh); + +=head1 ATTRIBUTES + +=head2 cipher + +A L<File::KDBX::Cipher> instance to do the actual encryption or decryption. + +=head1 METHODS + +=head2 new + + $fh = File::KDBX::IO::Crypt->new(%attributes); + $fh = File::KDBX::IO::Crypt->new($fh, %attributes); + +Construct a new crypto IO handle. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/IO/HashBlock.pm b/lib/File/KDBX/IO/HashBlock.pm new file mode 100644 index 0000000..0030957 --- /dev/null +++ b/lib/File/KDBX/IO/HashBlock.pm @@ -0,0 +1,286 @@ +package File::KDBX::IO::HashBlock; +# ABSTRACT: Hash block stream IO handle + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use Errno; +use File::KDBX::Error; +use File::KDBX::Util qw(:class :io); +use IO::Handle; +use namespace::clean; + +extends 'File::KDBX::IO'; + +our $VERSION = '0.800'; # VERSION +our $ALGORITHM = 'SHA256'; +our $BLOCK_SIZE = 1048576; # 1MiB +our $ERROR; + + +my %ATTRS = ( + _block_index => 0, + _buffer => sub { \(my $buf = '') }, + _finished => 0, + algorithm => sub { $ALGORITHM }, + block_size => sub { $BLOCK_SIZE }, +); +while (my ($attr, $default) = each %ATTRS) { + no strict 'refs'; ## no critic (ProhibitNoStrict) + *$attr = sub { + my $self = shift; + *$self->{$attr} = shift if @_; + *$self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default; + }; +} + + +sub new { + my $class = shift; + my %args = @_ % 2 == 1 ? (fh => shift, @_) : @_; + my $self = $class->SUPER::new; + $self->_fh($args{fh}) or throw 'IO handle required'; + $self->algorithm($args{algorithm}); + $self->block_size($args{block_size}); + $self->_buffer; + return $self; +} + +sub _FILL { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n"; + return if $self->_finished; + + my $block = eval { $self->_read_hash_block($fh) }; + if (my $err = $@) { + $self->_set_error($err); + return; + } + return $$block if defined $block; +} + +sub _WRITE { + my ($self, $buf, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n"; + return 0 if $self->_finished; + + ${$self->_buffer} .= $buf; + + $self->_FLUSH($fh); + + return length($buf); +} + +sub _POPPED { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n"; + return if $self->_mode ne 'w'; + + $self->_FLUSH($fh); + eval { + $self->_write_next_hash_block($fh); # partial block with remaining content + $self->_write_final_hash_block($fh); # terminating block + }; + $self->_set_error($@) if $@; +} + +sub _FLUSH { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n"; + return if $self->_mode ne 'w'; + + eval { + while ($self->block_size <= length(${*$self->{_buffer}})) { + $self->_write_next_hash_block($fh); + } + }; + if (my $err = $@) { + $self->_set_error($err); + return -1; + } + + return 0; +} + +############################################################################## + +sub _read_hash_block { + my $self = shift; + my $fh = shift; + + read_all $fh, my $buf, 4 or throw 'Failed to read hash block index'; + my ($index) = unpack('L<', $buf); + + $index == $self->_block_index or throw 'Invalid block index', index => $index; + + read_all $fh, my $hash, 32 or throw 'Failed to read hash'; + + read_all $fh, $buf, 4 or throw 'Failed to read hash block size'; + my ($size) = unpack('L<', $buf); + + if ($size == 0) { + $hash eq ("\0" x 32) or throw 'Invalid final block hash', hash => $hash; + $self->_finished(1); + return undef; + } + + read_all $fh, my $block, $size or throw 'Failed to read hash block', index => $index, size => $size; + + my $got_hash = digest_data($self->algorithm, $block); + $hash eq $got_hash + or throw 'Hash mismatch', index => $index, size => $size, got => $got_hash, expected => $hash; + + *$self->{_block_index}++; + return \$block; +} + +sub _write_next_hash_block { + my $self = shift; + my $fh = shift; + + my $size = length(${$self->_buffer}); + $size = $self->block_size if $self->block_size < $size; + return 0 if $size == 0; + + my $block = substr(${$self->_buffer}, 0, $size, ''); + + my $buf = pack('L<', $self->_block_index); + print $fh $buf or throw 'Failed to write hash block index'; + + my $hash = digest_data($self->algorithm, $block); + print $fh $hash or throw 'Failed to write hash'; + + $buf = pack('L<', length($block)); + print $fh $buf or throw 'Failed to write hash block size'; + + # $fh->write($block, $size) or throw 'Failed to hash write block'; + print $fh $block or throw 'Failed to hash write block'; + + *$self->{_block_index}++; + return 0; +} + +sub _write_final_hash_block { + my $self = shift; + my $fh = shift; + + my $buf = pack('L<', $self->_block_index); + print $fh $buf or throw 'Failed to write hash block index'; + + my $hash = "\0" x 32; + print $fh $hash or throw 'Failed to write hash'; + + $buf = pack('L<', 0); + print $fh $buf or throw 'Failed to write hash block size'; + + $self->_finished(1); + return 0; +} + +sub _set_error { + my $self = shift; + $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n"; + if (exists &Errno::EPROTO) { + $! = &Errno::EPROTO; + } + elsif (exists &Errno::EIO) { + $! = &Errno::EIO; + } + $self->_error($ERROR = error(@_)); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::IO::HashBlock - Hash block stream IO handle + +=head1 VERSION + +version 0.800 + +=head1 DESCRIPTION + +Writing to a hash-block handle will transform the data into a series of blocks. Each block is hashed, and the +hash is included with the block in the stream. + +Reading from a handle, each hash block will be verified as the blocks are disassembled back into a data +stream. + +This format helps ensure data integrity of KDBX3 files. + +Each block is encoded thusly: + +=over 4 + +=item * + +Block index - Little-endian unsigned 32-bit integer, increments starting with 0 + +=item * + +Hash - 32 bytes + +=item * + +Block size - Little-endian unsigned 32-bit (counting only the data) + +=item * + +Data - String of bytes + +=back + +The terminating block is an empty block where hash is 32 null bytes, block size is 0 and there is no data. + +=head1 ATTRIBUTES + +=head2 algorithm + +Digest algorithm in hash-blocking the stream (default: C<SHA-256>) + +=head2 block_size + +Desired block size when writing (default: C<$File::KDBX::IO::HashBlock::BLOCK_SIZE> or 1,048,576 bytes) + +=head1 METHODS + +=head2 new + + $fh = File::KDBX::IO::HashBlock->new(%attributes); + $fh = File::KDBX::IO::HashBlock->new($fh, %attributes); + +Construct a new hash-block stream IO handle. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/IO/HmacBlock.pm b/lib/File/KDBX/IO/HmacBlock.pm new file mode 100644 index 0000000..26209fb --- /dev/null +++ b/lib/File/KDBX/IO/HmacBlock.pm @@ -0,0 +1,288 @@ +package File::KDBX::IO::HmacBlock; +# ABSTRACT: HMAC block stream IO handle + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use Crypt::Mac::HMAC qw(hmac); +use Errno; +use File::KDBX::Error; +use File::KDBX::Util qw(:class :io assert_64bit); +use namespace::clean; + +extends 'File::KDBX::IO'; + +our $VERSION = '0.800'; # VERSION +our $BLOCK_SIZE = 1048576; # 1MiB +our $ERROR; + + +my %ATTRS = ( + _block_index => 0, + _buffer => sub { \(my $buf = '') }, + _finished => 0, + block_size => sub { $BLOCK_SIZE }, + key => undef, +); +while (my ($attr, $default) = each %ATTRS) { + no strict 'refs'; ## no critic (ProhibitNoStrict) + *$attr = sub { + my $self = shift; + *$self->{$attr} = shift if @_; + *$self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default; + }; +} + + +sub new { + assert_64bit; + + my $class = shift; + my %args = @_ % 2 == 1 ? (fh => shift, @_) : @_; + my $self = $class->SUPER::new; + $self->_fh($args{fh}) or throw 'IO handle required'; + $self->key($args{key}) or throw 'Key required'; + $self->block_size($args{block_size}); + $self->_buffer; + return $self; +} + +sub _FILL { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n"; + return if $self->_finished; + + my $block = eval { $self->_read_hashed_block($fh) }; + if (my $err = $@) { + $self->_set_error($err); + return; + } + if (length($block) == 0) { + $self->_finished(1); + return; + } + return $block; +} + +sub _WRITE { + my ($self, $buf, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self ($fh)\n"; + return 0 if $self->_finished; + + ${*$self->{_buffer}} .= $buf; + + $self->_FLUSH($fh); # TODO only if autoflush? + + return length($buf); +} + +sub _POPPED { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self ($fh)\n"; + return if $self->_mode ne 'w'; + + $self->_FLUSH($fh); + eval { + $self->_write_next_hmac_block($fh); # partial block with remaining content + $self->_write_final_hmac_block($fh); # terminating block + }; + $self->_set_error($@) if $@; +} + +sub _FLUSH { + my ($self, $fh) = @_; + + $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self ($fh)\n"; + return if $self->_mode ne 'w'; + + eval { + while ($self->block_size <= length(${*$self->{_buffer}})) { + $self->_write_next_hmac_block($fh); + } + }; + if (my $err = $@) { + $self->_set_error($err); + return -1; + } + + return 0; +} + +sub _set_error { + my $self = shift; + $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n"; + if (exists &Errno::EPROTO) { + $! = &Errno::EPROTO; + } + elsif (exists &Errno::EIO) { + $! = &Errno::EIO; + } + $self->_error($ERROR = error(@_)); +} + +############################################################################## + +sub _read_hashed_block { + my $self = shift; + my $fh = shift; + + read_all $fh, my $hmac, 32 or throw 'Failed to read HMAC'; + + read_all $fh, my $packed_size, 4 or throw 'Failed to read HMAC block size'; + my ($size) = unpack('L<', $packed_size); + + my $block = ''; + if (0 < $size) { + read_all $fh, $block, $size + or throw 'Failed to read HMAC block', index => $self->_block_index, size => $size; + } + + my $packed_index = pack('Q<', $self->_block_index); + my $got_hmac = hmac('SHA256', $self->_hmac_key, + $packed_index, + $packed_size, + $block, + ); + + $hmac eq $got_hmac + or throw 'Block authentication failed', index => $self->_block_index, got => $got_hmac, expected => $hmac; + + *$self->{_block_index}++; + return $block; +} + +sub _write_next_hmac_block { + my $self = shift; + my $fh = shift; + my $buffer = shift // $self->_buffer; + my $allow_empty = shift; + + my $size = length($$buffer); + $size = $self->block_size if $self->block_size < $size; + return 0 if $size == 0 && !$allow_empty; + + my $block = ''; + $block = substr($$buffer, 0, $size, '') if 0 < $size; + + my $packed_index = pack('Q<', $self->_block_index); + my $packed_size = pack('L<', $size); + my $hmac = hmac('SHA256', $self->_hmac_key, + $packed_index, + $packed_size, + $block, + ); + + $fh->print($hmac, $packed_size, $block) + or throw 'Failed to write HMAC block', hmac => $hmac, block_size => $size; + + *$self->{_block_index}++; + return 0; +} + +sub _write_final_hmac_block { + my $self = shift; + my $fh = shift; + + $self->_write_next_hmac_block($fh, \'', 1); +} + +sub _hmac_key { + my $self = shift; + my $key = shift // $self->key; + my $index = shift // $self->_block_index; + + my $packed_index = pack('Q<', $index); + my $hmac_key = digest_data('SHA512', $packed_index, $key); + return $hmac_key; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::IO::HmacBlock - HMAC block stream IO handle + +=head1 VERSION + +version 0.800 + +=head1 DESCRIPTION + +Writing to a HMAC-block stream handle will transform the data into a series of blocks. An HMAC is calculated +for each block and is included in the output. + +Reading from a handle, each block will be verified and authenticated as the blocks are disassembled back into +a data stream. + +This format helps ensure data integrity and authenticity of KDBX4 files. + +Each block is encoded thusly: + +=over 4 + +=item * + +HMAC - 32 bytes, calculated over [block index (increments starting with 0), block size and data] + +=item * + +Block size - Little-endian unsigned 32-bit (counting only the data) + +=item * + +Data - String of bytes + +=back + +The terminating block is an empty block encoded as usual but block size is 0 and there is no data. + +=head1 ATTRIBUTES + +=head2 block_size + +Desired block size when writing (default: C<$File::KDBX::IO::HmacBlock::BLOCK_SIZE> or 1,048,576 bytes) + +=head2 key + +HMAC-SHA256 key for authenticating the data stream (required) + +=head1 METHODS + +=head2 new + + $fh = File::KDBX::IO::HmacBlock->new(%attributes); + $fh = File::KDBX::IO::HmacBlock->new($fh, %attributes); + +Construct a new HMAC-block stream IO handle. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Iterator.pm b/lib/File/KDBX/Iterator.pm new file mode 100644 index 0000000..5a93f72 --- /dev/null +++ b/lib/File/KDBX/Iterator.pm @@ -0,0 +1,462 @@ +package File::KDBX::Iterator; +# ABSTRACT: KDBX database iterator + +use warnings; +use strict; + +use File::KDBX::Error; +use File::KDBX::Util qw(:class :load :search); +use Iterator::Simple; +use Module::Loaded; +use Ref::Util qw(is_arrayref is_coderef is_ref is_scalarref); +use namespace::clean; + +BEGIN { mark_as_loaded('Iterator::Simple::Iterator') } +extends 'Iterator::Simple::Iterator'; + +our $VERSION = '0.800'; # VERSION + + +sub new { + my $class = shift; + my $code = is_coderef($_[0]) ? shift : sub { undef }; + + my $items = @_ == 1 && is_arrayref($_[0]) ? $_[0] : \@_; + return $class->SUPER::new(sub { + if (@_) { # put back + if (@_ == 1 && is_arrayref($_[0])) { + $items = $_[0]; + } + else { + unshift @$items, @_; + } + return; + } + else { + my $next = shift @$items; + return $next if defined $next; + return $code->(); + } + }); +} + + +sub next { + my $self = shift; + my $code = shift or return $self->(); + + $code = query_any($code, @_); + + while (defined (local $_ = $self->())) { + return $_ if $code->($_); + } + return; +} + + +sub peek { + my $self = shift; + + my $next = $self->(); + $self->($next) if defined $next; + return $next; +} + + +sub unget { + my $self = shift; # Must shift in a statement before calling. + $self->(@_); +} + + +sub each { + my $self = shift; + my $cb = shift or return @{$self->to_array}; + + if (is_coderef($cb)) { + my $count = 0; + $cb->($_, $count++, @_) while defined (local $_ = $self->()); + } + elsif (!is_ref($cb)) { + $_->$cb(@_) while defined (local $_ = $self->()); + } + return $self; +} + + +sub where { shift->grep(@_) } + +sub grep { + my $self = shift; + my $code = query_any(@_); + + ref($self)->new(sub { + while (defined (local $_ = $self->())) { + return $_ if $code->($_); + } + return; + }); +} + + +sub map { + my $self = shift; + my $code = shift; + + ref($self)->new(sub { + local $_ = $self->(); + return if !defined $_; + return $code->(); + }); +} + + +sub order_by { + my $self = shift; + my $field = shift; + my %args = @_; + + my $ascending = delete $args{ascending} // !delete $args{descending} // 1; + my $case = delete $args{case} // !delete $args{no_case} // 1; + my $collate = (delete $args{collate} // !delete $args{no_collate} // 1) + && try_load_optional('Unicode::Collate'); + + if ($collate && !$case) { + $case = 1; + # use a proper Unicode::Collate level to ignore case + $args{level} //= 2; + } + $args{upper_before_lower} //= 1; + + my $value = $field; + $value = $case ? sub { $_[0]->$field // '' } : sub { uc($_[0]->$field) // '' } if !is_coderef($value); + my @all = CORE::map { [$_, $value->($_)] } @{$self->to_array}; + + if ($collate) { + my $c = Unicode::Collate->new(%args); + if ($ascending) { + @all = CORE::map { $_->[0] } CORE::sort { $c->cmp($a->[1], $b->[1]) } @all; + } else { + @all = CORE::map { $_->[0] } CORE::sort { $c->cmp($b->[1], $a->[1]) } @all; + } + } else { + if ($ascending) { + @all = CORE::map { $_->[0] } CORE::sort { $a->[1] cmp $b->[1] } @all; + } else { + @all = CORE::map { $_->[0] } CORE::sort { $b->[1] cmp $a->[1] } @all; + } + } + + $self->(\@all); + return $self; +} + + +sub sort_by { shift->order_by(@_) } + + +sub norder_by { + my $self = shift; + my $field = shift; + my %args = @_; + + my $ascending = $args{ascending} // !$args{descending} // 1; + + my $value = $field; + $value = sub { $_[0]->$field // 0 } if !is_coderef($value); + my @all = CORE::map { [$_, $value->($_)] } @{$self->to_array}; + + if ($ascending) { + @all = CORE::map { $_->[0] } CORE::sort { $a->[1] <=> $b->[1] } @all; + } else { + @all = CORE::map { $_->[0] } CORE::sort { $b->[1] <=> $a->[1] } @all; + } + + $self->(\@all); + return $self; +} + + +sub nsort_by { shift->norder_by(@_) } + + +sub limit { shift->head(@_) } + + +sub to_array { + my $self = shift; + + my @all; + push @all, $_ while defined (local $_ = $self->()); + return \@all; +} + + +sub count { + my $self = shift; + + my $items = $self->to_array; + $self->($items); + return scalar @$items; +} + + +sub size { shift->count } + +############################################################################## + +sub TO_JSON { $_[0]->to_array } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Iterator - KDBX database iterator + +=head1 VERSION + +version 0.800 + +=head1 SYNOPSIS + + my $kdbx = File::KDBX->load('database.kdbx', 'masterpw'); + + $kdbx->entries + ->where(sub { $_->title =~ /bank/i }) + ->order_by('title') + ->limit(5) + ->each(sub { + say $_->title; + }); + +=head1 DESCRIPTION + +A buffered iterator compatible with and expanding upon L<Iterator::Simple>, this provides an easy way to +navigate a L<File::KDBX> database. The documentation for B<Iterator::Simple> documents functions and methods +supported but this iterator that are not documented here, so consider that additional reading. + +=head2 Buffer + +This iterator is buffered, meaning it can drain from an iterator subroutine under the hood, storing items +temporarily to be accessed later. This allows features like L</peek> and L</sort> which might be useful in the +context of KDBX databases which are normally pretty small so draining an iterator isn't cost-prohibitive. + +The way this works is that if you call an iterator without arguments, it acts like a normal iterator. If you +call it with arguments, however, the arguments are added to the buffer. When called without arguments, the +buffer is drained before the iterator function is. Using L</unget> is equivalent to calling the iterator with +arguments, and as L</next> is equivalent to calling the iterator without arguments. + +=head1 METHODS + +=head2 new + + \&iterator = File::KDBX::Iterator->new(\&iterator); + +Blesses an iterator to augment it with buffering plus some useful utility methods. + +=head2 next + + $item = $iterator->next; + # OR equivalently + $item = $iterator->(); + + $item = $iterator->next(\&query); + $item = $iterator->next([\'simple expression', @fields]); + +Get the next item or C<undef> if there are no more items. If a query is passed, get the next matching item, +discarding any unmatching items before the matching item. Example: + + my $item = $iterator->next(sub { $_->label =~ /Gym/ }); + +=head2 peek + + $item = $iterator->peek; + +Peek at the next item. Returns C<undef> if the iterator is empty. This allows you to access the next item +without draining it from the iterator. The same item will be returned the next time L</next> is called. + +=head2 unget + + $iterator->unget(\@items); + $iterator->unget(...); + # OR equivalently + $iterator->(\@items); + $iterator->(...); + +Replace the buffer or unshift one or more items to the current buffer. + +See L</Buffer>. + +=head2 each + + @items = $iterator->each; + + $iterator->each(sub($item, $num, @args) { ... }, @args); + + $iterator->each($method_name, ...); + +Get or act on the rest of the items. There are three forms: + +=over 4 + +=item 1 + +Without arguments, C<each> returns a list of the rest of the items. + +=item 2 + +Pass a coderef to be called once per item, in order. Arguments to the coderef are the item itself (also C<$_>), its index number and then any extra arguments that were passed to C<each> after the coderef. + +=item 3 + +Pass a string that is the name of a method to be called on each object, in order. Any extra arguments passed to C<each> after the method name are passed through to each method call. This form requires each item be an object that C<can> the given method. + +=back + +B<NOTE:> This method drains the iterator completely, leaving it empty. See L</CAVEATS>. + +=head2 grep + +=head2 where + + \&iterator = $iterator->grep(\&query); + \&iterator = $iterator->grep([\'simple expression', @fields]); + +Get a new iterator draining from an existing iterator but providing only items that pass a test or are matched +by a query. + +=head2 map + + \&iterator = $iterator->map(\&code); + +Get a new iterator draining from an existing iterator but providing modified items. + +=head2 order_by + + \&iterator = $iterator->sort_by($field, %options); + \&iterator = $iterator->sort_by(\&get_value, %options); + +Get a new iterator draining from an existing iterator but providing items sorted by an object field. Sorting +is done using L<Unicode::Collate> (if available) or C<cmp> to sort alphanumerically. The C<\&get_value> +subroutine is called once for each item and should return a string value. Options: + +=over 4 + +=item * + +C<ascending> - Order ascending if true, descending otherwise (default: true) + +=item * + +C<case> - If true, take case into account, otherwise ignore case (default: true) + +=item * + +C<collate> - If true, use B<Unicode::Collate> (if available), otherwise use perl built-ins (default: true) + +=item * + +Any B<Unicode::Collate> option is also supported. + +=back + +C<sort_by> and C<order_by> are aliases. + +B<NOTE:> This method drains the iterator completely and places the sorted items onto the buffer. See +L</CAVEATS>. + +=head2 sort_by + +Alias for L</order_by>. + +=head2 norder_by + + \&iterator = $iterator->nsort_by($field, %options); + \&iterator = $iterator->nsort_by(\&get_value, %options); + +Get a new iterator draining from an existing iterator but providing items sorted by an object field. Sorting +is done numerically using C<< <=> >>. The C<\&get_value> subroutine or C<$field> accessor is called once for +each item and should return a numerical value. Options: + +=over 4 + +=item * + +C<ascending> - Order ascending if true, descending otherwise (default: true) + +=back + +C<nsort_by> and C<norder_by> are aliases. + +B<NOTE:> This method drains the iterator completely and places the sorted items onto the buffer. See +L</CAVEATS>. + +=head2 nsort_by + +Alias for L</norder_by>. + +=head2 limit + + \&iterator = $iterator->limit($count); + +Get a new iterator draining from an existing iterator but providing only a limited number of items. + +C<limit> as an alias for L<Iterator::Simple/"$iterator->head($count)">. + +=head2 to_array + + \@array = $iterator->to_array; + +Get the rest of the items from an iterator as an arrayref. + +B<NOTE:> This method drains the iterator completely, leaving it empty. See L</CAVEATS>. + +=head2 count + + $size = $iterator->count; + +Count the rest of the items from an iterator. + +B<NOTE:> This method drains the iterator completely but restores it to its pre-drained state. See L</CAVEATS>. + +=head2 size + +Alias for L</count>. + +=for Pod::Coverage TO_JSON + +=head1 CAVEATS + +Some methods attempt to drain the iterator completely before returning. For obvious reasons, this won't work +for infinite iterators because your computer doesn't have infinite memory. This isn't a practical issue with +B<File::KDBX> lists which are always finite -- unless you do something weird like force a child group to be +its own ancestor -- but I'm noting it here as a potential issue if you use this iterator class for other +things (which you probably shouldn't do). + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/KDF.pm b/lib/File/KDBX/KDF.pm new file mode 100644 index 0000000..19677c2 --- /dev/null +++ b/lib/File/KDBX/KDF.pm @@ -0,0 +1,256 @@ +package File::KDBX::KDF; +# ABSTRACT: A key derivation function + +use warnings; +use strict; + +use Crypt::PRNG qw(random_bytes); +use File::KDBX::Constants qw(:version :kdf); +use File::KDBX::Error; +use File::KDBX::Util qw(format_uuid); +use Module::Load; +use Scalar::Util qw(blessed); +use namespace::clean; + +our $VERSION = '0.800'; # VERSION + +my %KDFS; + + +sub new { + my $class = shift; + my %args = @_; + + my $uuid = $args{+KDF_PARAM_UUID} //= delete $args{uuid} or throw 'Missing KDF UUID', args => \%args; + my $formatted_uuid = format_uuid($uuid); + + my $kdf = $KDFS{$uuid} or throw "Unsupported KDF ($formatted_uuid)", uuid => $uuid; + ($class, my %registration_args) = @$kdf; + + load $class; + my $self = bless {KDF_PARAM_UUID() => $uuid}, $class; + return $self->init(%args, %registration_args); +} + + +sub init { + my $self = shift; + my %args = @_; + + @$self{keys %args} = values %args; + + return $self; +} + + +sub uuid { $_[0]->{+KDF_PARAM_UUID} } + + +sub seed { die 'Not implemented' } + + +sub transform { + my $self = shift; + my $key = shift; + + if (blessed $key && $key->can('raw_key')) { + return $self->_transform($key->raw_key) if $self->uuid eq KDF_UUID_AES; + return $self->_transform($key->raw_key($self->seed, @_)); + } + + return $self->_transform($key); +} + +sub _transform { die 'Not implemented' } + + +sub randomize_seed { + my $self = shift; + $self->{+KDF_PARAM_AES_SEED} = random_bytes(length($self->seed)); +} + + +sub register { + my $class = shift; + my $id = shift; + my $package = shift; + my @args = @_; + + my $formatted_id = format_uuid($id); + $package = "${class}::${package}" if $package !~ s/^\+// && $package !~ /^\Q${class}::\E/; + + my %blacklist = map { File::KDBX::Util::uuid($_) => 1 } split(/,/, $ENV{FILE_KDBX_KDF_BLACKLIST} // ''); + if ($blacklist{$id} || $blacklist{$package}) { + alert "Ignoring blacklisted KDF ($formatted_id)", id => $id, package => $package; + return; + } + + if (defined $KDFS{$id}) { + alert "Overriding already-registered KDF ($formatted_id) with package $package", + id => $id, + package => $package; + } + + $KDFS{$id} = [$package, @args]; +} + + +sub unregister { + delete $KDFS{$_} for @_; +} + +BEGIN { + __PACKAGE__->register(KDF_UUID_AES, 'AES'); + __PACKAGE__->register(KDF_UUID_AES_CHALLENGE_RESPONSE, 'AES'); + __PACKAGE__->register(KDF_UUID_ARGON2D, 'Argon2'); + __PACKAGE__->register(KDF_UUID_ARGON2ID, 'Argon2'); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::KDF - A key derivation function + +=head1 VERSION + +version 0.800 + +=head1 DESCRIPTION + +A KDF (key derivation function) is used in the transformation of a master key (i.e. one or more component +keys) to produce the final encryption key protecting a KDBX database. The L<File::KDBX> distribution comes +with several pre-registered KDFs ready to go: + +=over 4 + +=item * + +C<C9D9F39A-628A-4460-BF74-0D08C18A4FEA> - AES + +=item * + +C<7C02BB82-79A7-4AC0-927D-114A00648238> - AES (challenge-response variant) + +=item * + +C<EF636DDF-8C29-444B-91F7-A9A403E30A0C> - Argon2d + +=item * + +C<9E298B19-56DB-4773-B23D-FC3EC6F0A1E6> - Argon2id + +=back + +B<NOTE:> If you want your KDBX file to be readable by other KeePass implementations, you must use a UUID and +algorithm that they support. From the list above, all are well-supported except the AES challenge-response +variant which is kind of a pseudo KDF and isn't usually written into files. All of these are good. AES has +a longer track record, but Argon2 has better ASIC resistance. + +You can also L</register> your own KDF. Here is a skeleton: + + package File::KDBX::KDF::MyKDF; + + use parent 'File::KDBX::KDF'; + + File::KDBX::KDF->register( + # $uuid, $package, %args + "\x12\x34\x56\x78\x9a\xbc\xde\xfg\x12\x34\x56\x78\x9a\xbc\xde\xfg" => __PACKAGE__, + ); + + sub init { ... } # optional + + sub _transform { my ($key) = @_; ... } + +=head1 ATTRIBUTES + +=head2 uuid + + $uuid => $kdf->uuid; + +Get the UUID used to determine which function to use. + +=head2 seed + + $seed = $kdf->seed; + +Get the seed (or salt, depending on the function). + +=head1 METHODS + +=head2 new + + $kdf = File::KDBX::KDF->new(parameters => \%params); + +Construct a new KDF. + +=head2 init + + $kdf = $kdf->init(%attributes); + +Called by method to set attributes. You normally shouldn't call this. + +=head2 transform + + $transformed_key = $kdf->transform($key); + $transformed_key = $kdf->transform($key, $challenge); + +Transform a key. The input key can be either a L<File::KDBX::Key> or a raw binary key, and the +transformed key will be a raw key. + +This can take awhile, depending on the KDF parameters. + +If a challenge is provided (and the KDF is AES except for the KeePassXC variant), it will be passed to the key +so challenge-response keys can produce raw keys. See L<File::KDBX::Key/raw_key>. + +=head2 randomize_seed + + $kdf->randomize_seed; + +Generate a new random seed/salt. + +=head2 register + + File::KDBX::KDF->register($uuid => $package, %args); + +Register a KDF. Registered KDFs can be used to encrypt and decrypt KDBX databases. A KDF's UUID B<must> be +unique and B<musn't change>. A KDF UUID is written into each KDBX file and the associated KDF must be +registered with the same UUID in order to decrypt the KDBX file. + +C<$package> should be a Perl package relative to C<File::KDBX::KDF::> or prefixed with a C<+> if it is +a fully-qualified package. C<%args> are passed as-is to the KDF's L</init> method. + +=head2 unregister + + File::KDBX::KDF->unregister($uuid); + +Unregister a KDF. Unregistered KDFs can no longer be used to encrypt and decrypt KDBX databases, until +reregistered (see L</register>). + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/KDF/AES.pm b/lib/File/KDBX/KDF/AES.pm new file mode 100644 index 0000000..b2ed0bd --- /dev/null +++ b/lib/File/KDBX/KDF/AES.pm @@ -0,0 +1,157 @@ +package File::KDBX::KDF::AES; +# ABSTRACT: Using the AES cipher as a key derivation function + +use warnings; +use strict; + +use Crypt::Cipher; +use Crypt::Digest qw(digest_data); +use File::KDBX::Constants qw(:bool :kdf); +use File::KDBX::Error; +use File::KDBX::Util qw(:class :load can_fork); +use namespace::clean; + +extends 'File::KDBX::KDF'; + +our $VERSION = '0.800'; # VERSION + +# Rounds higher than this are eligible for forking: +my $FORK_OPTIMIZATION_THRESHOLD = 100_000; + +BEGIN { + my $use_fork = $ENV{NO_FORK} || !can_fork; + *_USE_FORK = $use_fork ? \&TRUE : \&FALSE; +} + + +sub rounds { $_[0]->{+KDF_PARAM_AES_ROUNDS} || KDF_DEFAULT_AES_ROUNDS } +sub seed { $_[0]->{+KDF_PARAM_AES_SEED} } + +sub init { + my $self = shift; + my %args = @_; + return $self->SUPER::init( + KDF_PARAM_AES_ROUNDS() => $args{+KDF_PARAM_AES_ROUNDS} // $args{rounds}, + KDF_PARAM_AES_SEED() => $args{+KDF_PARAM_AES_SEED} // $args{seed}, + ); +} + +sub _transform { + my $self = shift; + my $key = shift; + + my $seed = $self->seed; + my $rounds = $self->rounds; + + length($key) == 32 or throw 'Raw key must be 32 bytes', size => length($key); + length($seed) == 32 or throw 'Invalid seed length', size => length($seed); + + my ($key_l, $key_r) = unpack('(a16)2', $key); + + goto NO_FORK if !_USE_FORK || $rounds < $FORK_OPTIMIZATION_THRESHOLD; + { + my $pid = open(my $read, '-|') // do { alert "fork failed: $!"; goto NO_FORK }; + if ($pid == 0) { # child + my $l = _transform_half($seed, $key_l, $rounds); + require POSIX; + print $l or POSIX::_exit(1); + POSIX::_exit(0); + } + my $r = _transform_half($seed, $key_r, $rounds); + read($read, my $l, length($key_l)) == length($key_l) or do { alert "read failed: $!", goto NO_FORK }; + close($read) or do { alert "worker thread exited abnormally", status => $?; goto NO_FORK }; + return digest_data('SHA256', $l, $r); + } + + # FIXME: This used to work but now it crashes frequently. Threads are now discouraged anyway, but it might + # be nice if this was available for no-fork platforms. + # if ($ENV{THREADS} && eval 'use threads; 1') { + # my $l = threads->create(\&_transform_half, $key_l, $seed, $rounds); + # my $r = _transform_half($key_r, $seed, $rounds); + # return digest_data('SHA256', $l->join, $r); + # } + + NO_FORK: + my $l = _transform_half($seed, $key_l, $rounds); + my $r = _transform_half($seed, $key_r, $rounds); + return digest_data('SHA256', $l, $r); +} + +sub _transform_half_pp { + my $seed = shift; + my $key = shift; + my $rounds = shift; + + my $c = Crypt::Cipher->new('AES', $seed); + + my $result = $key; + for (my $i = 0; $i < $rounds; ++$i) { + $result = $c->encrypt($result); + } + + return $result; +} + +BEGIN { + my $use_xs = load_xs; + *_transform_half = $use_xs ? \&File::KDBX::XS::kdf_aes_transform_half : \&_transform_half_pp; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::KDF::AES - Using the AES cipher as a key derivation function + +=head1 VERSION + +version 0.800 + +=head1 DESCRIPTION + +An AES-256-based key derivation function. This is a L<File::KDBX::KDF> subclass. + +This KDF has a long, solid track record. It is supported in both KDBX3 and KDBX4. + +=head1 ATTRIBUTES + +=head2 rounds + + $rounds = $kdf->rounds; + +Get the number of times to run the function during transformation. + +=head1 CAVEATS + +This module can be pretty slow when the number of rounds is high. If you have L<File::KDBX::XS>, that will +help. If your perl has C<fork>, that will also help. If you need to turn off one or both of these +optimizations for some reason, set the C<PERL_ONLY> (to prevent Loading C<File::KDBX::XS>) and C<NO_FORK> +environment variables. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/KDF/Argon2.pm b/lib/File/KDBX/KDF/Argon2.pm new file mode 100644 index 0000000..b41c5e4 --- /dev/null +++ b/lib/File/KDBX/KDF/Argon2.pm @@ -0,0 +1,121 @@ +package File::KDBX::KDF::Argon2; +# ABSTRACT: The Argon2 family of key derivation functions + +use warnings; +use strict; + +use Crypt::Argon2 qw(argon2d_raw argon2id_raw); +use File::KDBX::Constants qw(:kdf); +use File::KDBX::Error; +use File::KDBX::Util qw(:class); +use namespace::clean; + +extends 'File::KDBX::KDF'; + +our $VERSION = '0.800'; # VERSION + + +sub salt { $_[0]->{+KDF_PARAM_ARGON2_SALT} or throw 'Salt is not set' } +sub seed { $_[0]->salt } +sub parallelism { $_[0]->{+KDF_PARAM_ARGON2_PARALLELISM} //= KDF_DEFAULT_ARGON2_PARALLELISM } +sub memory { $_[0]->{+KDF_PARAM_ARGON2_MEMORY} //= KDF_DEFAULT_ARGON2_MEMORY } +sub iterations { $_[0]->{+KDF_PARAM_ARGON2_ITERATIONS} //= KDF_DEFAULT_ARGON2_ITERATIONS } +sub version { $_[0]->{+KDF_PARAM_ARGON2_VERSION} //= KDF_DEFAULT_ARGON2_VERSION } +sub secret { $_[0]->{+KDF_PARAM_ARGON2_SECRET} } +sub assocdata { $_[0]->{+KDF_PARAM_ARGON2_ASSOCDATA} } + +sub init { + my $self = shift; + my %args = @_; + return $self->SUPER::init( + KDF_PARAM_ARGON2_SALT() => $args{+KDF_PARAM_ARGON2_SALT} // $args{salt}, + KDF_PARAM_ARGON2_PARALLELISM() => $args{+KDF_PARAM_ARGON2_PARALLELISM} // $args{parallelism}, + KDF_PARAM_ARGON2_MEMORY() => $args{+KDF_PARAM_ARGON2_MEMORY} // $args{memory}, + KDF_PARAM_ARGON2_ITERATIONS() => $args{+KDF_PARAM_ARGON2_ITERATIONS} // $args{iterations}, + KDF_PARAM_ARGON2_VERSION() => $args{+KDF_PARAM_ARGON2_VERSION} // $args{version}, + KDF_PARAM_ARGON2_SECRET() => $args{+KDF_PARAM_ARGON2_SECRET} // $args{secret}, + KDF_PARAM_ARGON2_ASSOCDATA() => $args{+KDF_PARAM_ARGON2_ASSOCDATA} // $args{assocdata}, + ); +} + +sub _transform { + my $self = shift; + my $key = shift; + + my ($uuid, $salt, $iterations, $memory, $parallelism) + = ($self->uuid, $self->salt, $self->iterations, $self->memory, $self->parallelism); + + if ($uuid eq KDF_UUID_ARGON2D) { + return argon2d_raw($key, $salt, $iterations, $memory, $parallelism, length($salt)); + } + elsif ($uuid eq KDF_UUID_ARGON2ID) { + return argon2id_raw($key, $salt, $iterations, $memory, $parallelism, length($salt)); + } + + throw 'Unknown Argon2 type', uuid => $uuid; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::KDF::Argon2 - The Argon2 family of key derivation functions + +=head1 VERSION + +version 0.800 + +=head1 DESCRIPTION + +An Argon2 key derivation function. This is a L<File::KDBX::KDF> subclass. + +This KDF allows for excellent resistance to ASIC password cracking. It's a solid choice but doesn't have the +track record of L<File::KDBX::KDF::AES> and requires using the KDBX4+ file format. + +=head1 ATTRIBUTES + +=head2 salt + +=head2 parallelism + +=head2 memory + +=head2 iterations + +=head2 version + +=head2 secret + +=head2 assocdata + +Get various KDF parameters. + +C<version>, C<secret> and C<assocdata> are currently unused. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Key.pm b/lib/File/KDBX/Key.pm new file mode 100644 index 0000000..c7bb2b3 --- /dev/null +++ b/lib/File/KDBX/Key.pm @@ -0,0 +1,293 @@ +package File::KDBX::Key; +# ABSTRACT: A credential that can protect a KDBX file + +use warnings; +use strict; + +use Devel::GlobalDestruction; +use File::KDBX::Error; +use File::KDBX::Safe; +use File::KDBX::Util qw(erase); +use Hash::Util::FieldHash qw(fieldhashes); +use Module::Load; +use Ref::Util qw(is_arrayref is_coderef is_hashref is_ref is_scalarref); +use Scalar::Util qw(blessed openhandle); +use namespace::clean; + +our $VERSION = '0.800'; # VERSION + +fieldhashes \my %SAFE; + + +sub new { + my $class = shift; + my %args = @_ % 2 == 1 ? (primitive => shift, @_) : @_; + + my $primitive = $args{primitive}; + delete $args{primitive} if !$args{keep_primitive}; + return $primitive->hide if blessed $primitive && $primitive->isa($class); + + my $self = bless \%args, $class; + return $self->init($primitive) if defined $primitive; + return $self; +} + +sub DESTROY { + local ($., $@, $!, $^E, $?); + !in_global_destruction and do { $_[0]->_clear_raw_key; eval { erase \$_[0]->{primitive} } } +} + + +sub init { + my $self = shift; + my $primitive = shift // throw 'Missing key primitive'; + + my $pkg; + + if (is_arrayref($primitive)) { + $pkg = __PACKAGE__.'::Composite'; + } + elsif (is_scalarref($primitive) || openhandle($primitive)) { + $pkg = __PACKAGE__.'::File'; + } + elsif (is_coderef($primitive)) { + $pkg = __PACKAGE__.'::ChallengeResponse'; + } + elsif (!is_ref($primitive)) { + $pkg = __PACKAGE__.'::Password'; + } + elsif (is_hashref($primitive) && defined $primitive->{composite}) { + $pkg = __PACKAGE__.'::Composite'; + $primitive = $primitive->{composite}; + } + elsif (is_hashref($primitive) && defined $primitive->{password}) { + $pkg = __PACKAGE__.'::Password'; + $primitive = $primitive->{password}; + } + elsif (is_hashref($primitive) && defined $primitive->{file}) { + $pkg = __PACKAGE__.'::File'; + $primitive = $primitive->{file}; + } + elsif (is_hashref($primitive) && defined $primitive->{responder}) { + $pkg = __PACKAGE__.'::ChallengeResponse'; + $primitive = $primitive->{responder}; + } + else { + throw 'Invalid key primitive', primitive => $primitive; + } + + load $pkg; + bless $self, $pkg; + return $self->init($primitive); +} + + +sub reload { $_[0] } + + +sub raw_key { + my $self = shift; + return $self->{raw_key} if !$self->is_hidden; + return $self->_safe->peek(\$self->{raw_key}); +} + +sub _set_raw_key { + my $self = shift; + $self->_clear_raw_key; + $self->{raw_key} = shift; # after clear + $self->_new_safe->add(\$self->{raw_key}); # auto-hide +} + +sub _clear_raw_key { + my $self = shift; + my $safe = $self->_safe; + $safe->clear if $safe; + erase \$self->{raw_key}; +} + + +sub hide { + my $self = shift; + $self->_new_safe->add(\$self->{raw_key}) if defined $self->{raw_key}; + return $self; +} + + +sub show { + my $self = shift; + my $safe = $self->_safe; + $safe->unlock if $safe; + return $self; +} + + +sub is_hidden { !!$SAFE{$_[0]} } + +sub _safe { $SAFE{$_[0]} } +sub _new_safe { $SAFE{$_[0]} = File::KDBX::Safe->new } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Key - A credential that can protect a KDBX file + +=head1 VERSION + +version 0.800 + +=head1 DESCRIPTION + +A master key is one or more credentials that can protect a KDBX database. When you encrypt a database with +a master key, you will need the master key to decrypt it. B<Keep your master key safe!> If someone gains +access to your master key, they can open your database. If you forget or lose any part of your master key, all +data in the database is lost. + +There are several different types of keys, each implemented as a subclass: + +=over 4 + +=item * + +L<File::KDBX::Key::Password> - Password or passphrase, knowledge of a string of characters + +=item * + +L<File::KDBX::Key::File> - Possession of a file ("key file") with a secret. + +=item * + +L<File::KDBX::Key::ChallengeResponse> - Possession of a device that responds correctly when challenged + +=item * + +L<File::KDBX::Key::YubiKey> - Possession of a YubiKey hardware device (a type of challenge-response) + +=item * + +L<File::KDBX::Key::Composite> - One or more keys combined as one + +=back + +A good master key is produced from a high amount of "entropy" (unpredictability). The more entropy the better. +Combining multiple keys into a B<Composite> key combines the entropy of each individual key. For example, if +you have a weak password and you combine it with other keys, the composite key is stronger than the weak +password key by itself. (Of course it's much better to not have any weak components of your master key.) + +B<COMPATIBILITY NOTE:> Most KeePass implementations are limited in the types and numbers of keys they support. +B<Password> keys are pretty much universally supported. B<File> keys are pretty well-supported. Many do not +support challenge-response keys. If you are concerned about compatibility, you should stick with one of these +configurations: + +=over 4 + +=item * + +One password + +=item * + +One key file + +=item * + +One password and one key file + +=back + +=head1 METHODS + +=head2 new + + $key = File::KDBX::Key->new({ password => $password }); + $key = File::KDBX::Key->new($password); + + $key = File::KDBX::Key->new({ file => $filepath }); + $key = File::KDBX::Key->new(\$file); + $key = File::KDBX::Key->new(\*FILE); + + $key = File::KDBX::Key->new({ composite => [...] }); + $key = File::KDBX::Key->new([...]); # composite key + + $key = File::KDBX::Key->new({ responder => \&responder }); + $key = File::KDBX::Key->new(\&responder); # challenge-response key + +Construct a new key. + +The primitive used to construct the key is not saved but is immediately converted to a raw encryption key (see +L</raw_key>). + +A L<File::KDBX::Key::Composite> is somewhat special in that it does retain a reference to its component keys, +and its raw key is calculated from its components on demand. + +=head2 init + + $key = $key->init($primitive); + +Initialize a L<File::KDBX::Key> with a new primitive. Returns itself to allow method chaining. + +=head2 reload + + $key = $key->reload; + +Reload a key by re-reading the key source and recalculating the raw key. Returns itself to allow method +chaining. + +=head2 raw_key + + $raw_key = $key->raw_key; + $raw_key = $key->raw_key($challenge); + +Get the raw encryption key. This is calculated based on the primitive(s). The C<$challenge> argument is for +challenge-response type keys and is ignored by other types. + +B<NOTE:> The raw key is sensitive information and so is memory-protected while not being accessed. If you +access it, you should memzero or L<File::KDBX::Util/erase> it when you're done. + +=head2 hide + + $key = $key->hide; + +Put the raw key in L<File::KDBX/"Memory Protection">. Does nothing if the raw key is already in memory +protection. Returns itself to allow method chaining. + +=head2 show + + $key = $key->show; + +Bring the raw key out of memory protection. Does nothing if the raw key is already out of memory protection. +Returns itself to allow method chaining. + +=head2 is_hidden + + $bool = $key->is_hidden; + +Get whether or not the key's raw secret is currently in memory protection. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Key/ChallengeResponse.pm b/lib/File/KDBX/Key/ChallengeResponse.pm new file mode 100644 index 0000000..8f9dbde --- /dev/null +++ b/lib/File/KDBX/Key/ChallengeResponse.pm @@ -0,0 +1,122 @@ +package File::KDBX::Key::ChallengeResponse; +# ABSTRACT: A challenge-response key + +use warnings; +use strict; + +use File::KDBX::Error; +use File::KDBX::Util qw(:class); +use namespace::clean; + +extends 'File::KDBX::Key'; + +our $VERSION = '0.800'; # VERSION + +sub init { + my $self = shift; + my $primitive = shift or throw 'Missing key primitive'; + + $self->{responder} = $primitive; + + return $self->hide; +} + + +sub raw_key { + my $self = shift; + if (@_) { + my $challenge = shift // ''; + # Don't challenge if we already have the response. + return $self->SUPER::raw_key if $challenge eq ($self->{challenge} // ''); + $self->_set_raw_key($self->challenge($challenge, @_)); + $self->{challenge} = $challenge; + } + $self->SUPER::raw_key; +} + + +sub challenge { + my $self = shift; + + my $responder = $self->{responder} or throw 'Cannot issue challenge without a responder'; + return $responder->(@_); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Key::ChallengeResponse - A challenge-response key + +=head1 VERSION + +version 0.800 + +=head1 SYNOPSIS + + use File::KDBX::Key::ChallengeResponse; + + my $responder = sub { + my $challenge = shift; + ...; # generate a response based on a secret of some sort + return $response; + }; + my $key = File::KDBX::Key::ChallengeResponse->new($responder); + +=head1 DESCRIPTION + +A challenge-response key is kind of like multifactor authentication, except you don't really I<authenticate> +to a KDBX database because it's not a service. Specifically it would be the "what you have" component. It +assumes there is some device that can store a key that is only known to the unlocker of a database. +A challenge is made to the device and the response generated based on the key is used as the raw key. + +Inherets methods and attributes from L<File::KDBX::Key>. + +This is a generic implementation where a responder subroutine is provided to provide the response. There is +also L<File::KDBX::Key::YubiKey> which is a subclass that allows YubiKeys to be responder devices. + +=head1 METHODS + +=head2 raw_key + + $raw_key = $key->raw_key; + $raw_key = $key->raw_key($challenge); + +Get the raw key which is the response to a challenge. The response will be saved so that subsequent calls +(with or without the challenge) can provide the response without challenging the responder again. Only once +response is saved at a time; if you call this with a different challenge, the new response is saved over any +previous response. + +=head2 challenge + + $response = $key->challenge($challenge, @options); + +Issue a challenge and get a response, or throw if the responder failed to provide one. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Key/Composite.pm b/lib/File/KDBX/Key/Composite.pm new file mode 100644 index 0000000..a1d173a --- /dev/null +++ b/lib/File/KDBX/Key/Composite.pm @@ -0,0 +1,156 @@ +package File::KDBX::Key::Composite; +# ABSTRACT: A composite key made up of component keys + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use File::KDBX::Error; +use File::KDBX::Util qw(:class :erase); +use Ref::Util qw(is_arrayref); +use Scalar::Util qw(blessed); +use namespace::clean; + +extends 'File::KDBX::Key'; + +our $VERSION = '0.800'; # VERSION + +sub init { + my $self = shift; + my $primitive = shift // throw 'Missing key primitive'; + + my @primitive = grep { defined } is_arrayref($primitive) ? @$primitive : $primitive; + @primitive or throw 'Composite key must have at least one component key', count => scalar @primitive; + + my @keys = map { blessed $_ && $_->can('raw_key') ? $_ : File::KDBX::Key->new($_, + keep_primitive => $self->{keep_primitive}) } @primitive; + $self->{keys} = \@keys; + + return $self->hide; +} + + +sub raw_key { + my $self = shift; + my $challenge = shift; + + my @keys = @{$self->keys} or throw 'Cannot generate a raw key from an empty composite key'; + + my @basic_keys = map { $_->raw_key } grep { !$_->can('challenge') } @keys; + my $response; + $response = $self->challenge($challenge, @_) if defined $challenge; + my $cleanup = erase_scoped \@basic_keys, $response; + + return digest_data('SHA256', + @basic_keys, + defined $response ? $response : (), + ); +} + + +sub keys { + my $self = shift; + $self->{keys} = shift if @_; + return $self->{keys} ||= []; +} + + +sub challenge { + my $self = shift; + + my @chalresp_keys = grep { $_->can('challenge') } @{$self->keys} or return ''; + + my @responses = map { $_->challenge(@_) } @chalresp_keys; + my $cleanup = erase_scoped \@responses; + + return digest_data('SHA256', @responses); +} + +sub hide { + my $self = shift; + $_->hide for @{$self->keys}; + return $self; +} + +sub show { + my $self = shift; + $_->show for @{$self->keys}; + return $self; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Key::Composite - A composite key made up of component keys + +=head1 VERSION + +version 0.800 + +=head1 SYNOPSIS + + use File::KDBX::Key::Composite; + + my $key = File::KDBX::Key::Composite->(\@component_keys); + +=head1 DESCRIPTION + +A composite key is a collection of other keys. A master key capable of unlocking a KDBX database is always +a composite key, even if it only has a single component. + +Inherets methods and attributes from L<File::KDBX::Key>. + +=head1 ATTRIBUTES + +=head2 keys + + \@keys = $key->keys; + +Get one or more component L<File::KDBX::Key>. + +=head1 METHODS + +=head2 raw_key + + $raw_key = $key->raw_key; + $raw_key = $key->raw_key($challenge); + +Get the raw key from each component key and return a generated composite raw key. + +=head2 challenge + + $response = $key->challenge(...); + +Issues a challenge to any L<File::KDBX::Key::ChallengeResponse> components keys. Arguments are passed through +to each component key. The responses are hashed together and the composite response is returned. + +Returns empty string if there are no challenge-response components keys. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Key/File.pm b/lib/File/KDBX/Key/File.pm new file mode 100644 index 0000000..efbbbd2 --- /dev/null +++ b/lib/File/KDBX/Key/File.pm @@ -0,0 +1,402 @@ +package File::KDBX::Key::File; +# ABSTRACT: A file key + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use Crypt::Misc 0.029 qw(decode_b64 encode_b64); +use Crypt::PRNG qw(random_bytes); +use File::KDBX::Constants qw(:key_file); +use File::KDBX::Error; +use File::KDBX::Util qw(:class :erase trim); +use Ref::Util qw(is_ref is_scalarref); +use Scalar::Util qw(openhandle); +use XML::LibXML::Reader; +use namespace::clean; + +extends 'File::KDBX::Key'; + +our $VERSION = '0.800'; # VERSION + + +has 'type', is => 'ro'; +has 'version', is => 'ro'; +has 'filepath', is => 'ro'; + + +sub init { shift->load(@_) } + +sub load { + my $self = shift; + my $primitive = shift // throw 'Missing key primitive'; + + my $data; + my $cleanup; + + if (openhandle($primitive)) { + seek $primitive, 0, 0; # not using ->seek method so it works on perl 5.10 + my $buf = do { local $/; <$primitive> }; + $data = \$buf; + $cleanup = erase_scoped $data; + } + elsif (is_scalarref($primitive)) { + $data = $primitive; + } + elsif (defined $primitive && !is_ref($primitive)) { + open(my $fh, '<:raw', $primitive) + or throw "Failed to open key file ($primitive)", filepath => $primitive; + my $buf = do { local $/; <$fh> }; + $data = \$buf; + $cleanup = erase_scoped $data; + $self->{filepath} = $primitive; + } + else { + throw 'Unexpected primitive type', type => ref $primitive; + } + + my $raw_key; + if (substr($$data, 0, 120) =~ /<KeyFile>/ + and my ($type, $version) = $self->_load_xml($data, \$raw_key)) { + $self->{type} = $type; + $self->{version} = $version; + $self->_set_raw_key($raw_key); + } + elsif (length($$data) == 32) { + $self->{type} = KEY_FILE_TYPE_BINARY; + $self->_set_raw_key($$data); + } + elsif ($$data =~ /^[A-Fa-f0-9]{64}$/) { + $self->{type} = KEY_FILE_TYPE_HEX; + $self->_set_raw_key(pack('H64', $$data)); + } + else { + $self->{type} = KEY_FILE_TYPE_HASHED; + $self->_set_raw_key(digest_data('SHA256', $$data)); + } + + return $self->hide; +} + + +sub reload { + my $self = shift; + $self->init($self->{filepath}) if defined $self->{filepath}; + return $self; +} + + +sub save { + my $self = shift; + my %args = @_; + + my @cleanup; + my $raw_key = $args{raw_key} // $self->raw_key // random_bytes(32); + push @cleanup, erase_scoped $raw_key; + length($raw_key) == 32 or throw 'Raw key must be exactly 256 bits (32 bytes)', length => length($raw_key); + + my $type = $args{type} // $self->type // KEY_FILE_TYPE_XML; + my $version = $args{version} // $self->version // 2; + my $filepath = $args{filepath} // $self->filepath; + my $fh = $args{fh}; + + my $filepath_temp; + if (!openhandle($fh)) { + $filepath or throw 'Must specify where to safe the key file to'; + + require File::Temp; + ($fh, $filepath_temp) = eval { File::Temp::tempfile("${filepath}-XXXXXX", CLEANUP => 1) }; + if (!$fh or my $err = $@) { + $err //= 'Unknown error'; + throw sprintf('Open file failed (%s): %s', $filepath_temp, $err), + error => $err, + filepath => $filepath_temp; + } + } + + if ($type == KEY_FILE_TYPE_XML) { + $self->_save_xml($fh, $raw_key, $version); + } + elsif ($type == KEY_FILE_TYPE_BINARY) { + print $fh $raw_key; + } + elsif ($type == KEY_FILE_TYPE_HEX) { + my $hex = uc(unpack('H*', $raw_key)); + push @cleanup, erase_scoped $hex; + print $fh $hex; + } + else { + throw "Cannot save $type key file (invalid type)", type => $type; + } + + close($fh); + + if ($filepath_temp) { + my ($file_mode, $file_uid, $file_gid) = (stat($filepath))[2, 4, 5]; + + my $mode = $args{mode} // $file_mode // do { my $m = umask; defined $m ? oct(666) &~ $m : undef }; + my $uid = $args{uid} // $file_uid // -1; + my $gid = $args{gid} // $file_gid // -1; + chmod($mode, $filepath_temp) if defined $mode; + chown($uid, $gid, $filepath_temp); + rename($filepath_temp, $filepath) + or throw "Failed to write file ($filepath): $!", filepath => $filepath; + } +} + +############################################################################## + +sub _load_xml { + my $self = shift; + my $buf = shift; + my $out = shift; + + my ($version, $hash, $data); + + my $reader = XML::LibXML::Reader->new(string => $$buf); + my $pattern = XML::LibXML::Pattern->new('/KeyFile/Meta/Version|/KeyFile/Key/Data'); + + while ($reader->nextPatternMatch($pattern) == 1) { + next if $reader->nodeType != XML_READER_TYPE_ELEMENT; + my $name = $reader->localName; + if ($name eq 'Version') { + $reader->read if !$reader->isEmptyElement; + $reader->nodeType == XML_READER_TYPE_TEXT + or alert 'Expected text node with version', line => $reader->lineNumber; + my $val = trim($reader->value); + defined $version + and alert 'Overwriting version', previous => $version, new => $val, line => $reader->lineNumber; + $version = $val; + } + elsif ($name eq 'Data') { + $hash = trim($reader->getAttribute('Hash')) if $reader->hasAttributes; + $reader->read if !$reader->isEmptyElement; + $reader->nodeType == XML_READER_TYPE_TEXT + or alert 'Expected text node with data', line => $reader->lineNumber; + $data = $reader->value; + $data =~ s/\s+//g if defined $data; + } + } + + return if !defined $version || !defined $data; + + if ($version =~ /^1\.0/ && $data =~ /^[A-Za-z0-9+\/=]+$/) { + $$out = eval { decode_b64($data) }; + if (my $err = $@) { + throw 'Failed to decode key in key file', version => $version, data => $data, error => $err; + } + return (KEY_FILE_TYPE_XML, $version); + } + elsif ($version =~ /^2\.0/ && $data =~ /^[A-Fa-f0-9]+$/ && defined $hash && $hash =~ /^[A-Fa-f0-9]+$/) { + $$out = pack('H*', $data); + $hash = pack('H*', $hash); + my $got_hash = digest_data('SHA256', $$out); + $hash eq substr($got_hash, 0, length($hash)) + or throw 'Checksum mismatch', got => $got_hash, expected => $hash; + return (KEY_FILE_TYPE_XML, $version); + } + + throw 'Unexpected data in key file', version => $version, data => $data; +} + +sub _save_xml { + my $self = shift; + my $fh = shift; + my $raw_key = shift; + my $version = shift // 2; + + my @cleanup; + + my $dom = XML::LibXML::Document->new('1.0', 'UTF-8'); + my $doc = XML::LibXML::Element->new('KeyFile'); + $dom->setDocumentElement($doc); + my $meta_node = XML::LibXML::Element->new('Meta'); + $doc->appendChild($meta_node); + my $version_node = XML::LibXML::Element->new('Version'); + $version_node->appendText(sprintf('%.1f', $version)); + $meta_node->appendChild($version_node); + my $key_node = XML::LibXML::Element->new('Key'); + $doc->appendChild($key_node); + my $data_node = XML::LibXML::Element->new('Data'); + $key_node->appendChild($data_node); + + if (int($version) == 1) { + my $b64 = encode_b64($raw_key); + push @cleanup, erase_scoped $b64; + $data_node->appendText($b64); + } + elsif (int($version) == 2) { + my @hex = unpack('(H8)8', $raw_key); + my $hex = uc(sprintf("\n %s\n %s\n ", join(' ', @hex[0..3]), join(' ', @hex[4..7]))); + push @cleanup, erase_scoped $hex, @hex; + $data_node->appendText($hex); + my $hash = digest_data('SHA256', $raw_key); + substr($hash, 4) = ''; + $hash = uc(unpack('H*', $hash)); + $data_node->setAttribute('Hash', $hash); + } + else { + throw 'Failed to save unsupported key file version', version => $version; + } + + $dom->toFH($fh, 1); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Key::File - A file key + +=head1 VERSION + +version 0.800 + +=head1 SYNOPSIS + + use File::KDBX::Constants qw(:key_file); + use File::KDBX::Key::File; + + ### Create a key file: + + my $key = File::KDBX::Key::File->new( + filepath => 'path/to/file.keyx', + type => KEY_FILE_TYPE_XML, # optional + version => 2, # optional + raw_key => $raw_key, # optional - leave undefined to generate a random key + ); + $key->save; + + ### Use a key file: + + my $key2 = File::KDBX::Key::File->new('path/to/file.keyx'); + # OR + my $key2 = File::KDBX::Key::File->new(\$secret); + # OR + my $key2 = File::KDBX::Key::File->new($fh); # or *IO + +=head1 DESCRIPTION + +A file key (or "key file") is the type of key where the secret is a file. The secret is either the file +contents or is generated based on the file contents. In order to lock and unlock a KDBX database with a key +file, the same file must be presented. The database cannot be opened without the file. + +Inherets methods and attributes from L<File::KDBX::Key>. + +There are multiple types of key files supported. See L</type>. This module can read and write key files. + +=head1 ATTRIBUTES + +=head2 type + + $type = $key->type; + +Get the type of key file. Can be one of: + +=over 4 + +=item * + +C<KEY_FILE_TYPE_BINARY> + +=item * + +C<KEY_FILE_TYPE_HEX> + +=item * + +C<KEY_FILE_TYPE_XML> + +=item * + +C<KEY_FILE_TYPE_HASHED> + +=back + +=head2 version + + $version = $key->version; + +Get the file version. Only applies to XML key files. + +=head2 filepath + + $filepath = $key->filepath; + +Get the filepath to the key file, if known. + +=head1 METHODS + +=head2 load + + $key = $key->load($filepath); + $key = $key->load(\$string); + $key = $key->load($fh); + $key = $key->load(*IO); + +Load a key file. + +=head2 reload + + $key->reload; + +Re-read the key file, if possible, and update the raw key if the key changed. + +=head2 save + + $key->save; + $key->save(%options); + +Write a key file. Available options: + +=over 4 + +=item * + +C<type> - Type of key file (default: value of L</type>, or C<KEY_FILE_TYPE_XML>) + +=item * + +C<verson> - Version of key file (default: value of L</version>, or 2) + +=item * + +C<filepath> - Where to save the file (default: value of L</filepath>) + +=item * + +C<fh> - IO handle to write to (overrides C<filepath>, one of which must be defined) + +=item * + +C<raw_key> - Raw key (default: value of L</raw_key>) + +=back + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Key/Password.pm b/lib/File/KDBX/Key/Password.pm new file mode 100644 index 0000000..24568a3 --- /dev/null +++ b/lib/File/KDBX/Key/Password.pm @@ -0,0 +1,74 @@ +package File::KDBX::Key::Password; +# ABSTRACT: A password key + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use Encode qw(encode); +use File::KDBX::Error; +use File::KDBX::Util qw(:class erase); +use namespace::clean; + +extends 'File::KDBX::Key'; + +our $VERSION = '0.800'; # VERSION + +sub init { + my $self = shift; + my $primitive = shift // throw 'Missing key primitive'; + + $self->_set_raw_key(digest_data('SHA256', encode('UTF-8', $primitive))); + + return $self->hide; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Key::Password - A password key + +=head1 VERSION + +version 0.800 + +=head1 SYNOPSIS + + use File::KDBX::Key::Password; + + my $key = File::KDBX::Key::Password->new($password); + +=head1 DESCRIPTION + +A password key is as simple as it sounds. It's just a password or passphrase. + +Inherets methods and attributes from L<File::KDBX::Key>. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Key/YubiKey.pm b/lib/File/KDBX/Key/YubiKey.pm new file mode 100644 index 0000000..f29df01 --- /dev/null +++ b/lib/File/KDBX/Key/YubiKey.pm @@ -0,0 +1,513 @@ +package File::KDBX::Key::YubiKey; +# ABSTRACT: A Yubico challenge-response key + +use warnings; +use strict; + +use File::KDBX::Constants qw(:yubikey); +use File::KDBX::Error; +use File::KDBX::Util qw(:class :io pad_pkcs7); +use IPC::Cmd 0.52 qw(run_forked); +use Ref::Util qw(is_arrayref); +use Symbol qw(gensym); +use namespace::clean; + +extends 'File::KDBX::Key::ChallengeResponse'; + +our $VERSION = '0.800'; # VERSION + +# It can take some time for the USB device to be ready again, so we can retry a few times. +our $RETRY_COUNT = 5; +our $RETRY_INTERVAL = 0.1; + +my @CONFIG_VALID = (0, CONFIG1_VALID, CONFIG2_VALID); +my @CONFIG_TOUCH = (0, CONFIG1_TOUCH, CONFIG2_TOUCH); + +sub challenge { + my $self = shift; + my $challenge = shift; + my %args = @_; + + my $device = $args{device} // $self->device; + my $slot = $args{slot} // $self->slot; + my $timeout = $args{timeout} // $self->timeout; + local $self->{device} = $device; + local $self->{slot} = $slot; + local $self->{timeout} = $timeout; + + my $hooks = $challenge ne 'test'; + if ($hooks and my $hook = $self->{pre_challenge}) { + $hook->($self, $challenge); + } + + my @cmd = ($self->_program('ykchalresp'), "-n$device", "-$slot", qw{-H -i-}, $timeout == 0 ? '-N' : ()); + + my $r; + my $try = 0; + TRY: + { + $r = $self->_run_ykpers(\@cmd, { + (0 < $timeout ? (timeout => $timeout) : ()), + child_stdin => pad_pkcs7($challenge, 64), + terminate_on_parent_sudden_death => 1, + }); + + if (my $t = $r->{timeout}) { + throw 'Timed out while waiting for challenge response', + command => \@cmd, + challenge => $challenge, + timeout => $t, + result => $r; + } + + my $exit_code = $r->{exit_code}; + if ($exit_code != 0) { + my $err = $r->{stderr}; + chomp $err; + my $yk_errno = _yk_errno($err); + if ($yk_errno == YK_EUSBERR && $err =~ /resource busy/i && ++$try <= $RETRY_COUNT) { + sleep $RETRY_INTERVAL; + goto TRY; + } + throw 'Failed to receive challenge response: ' . ($err ? $err : 'Something happened'), + error => $err, + yk_errno => $yk_errno || 0; + } + } + + my $resp = $r->{stdout}; + chomp $resp; + $resp =~ /^[A-Fa-f0-9]+$/ or throw 'Unexpected response from challenge', response => $resp, result => $r; + $resp = pack('H*', $resp); + + # HMAC-SHA1 response is only 20 bytes + substr($resp, 20) = ''; + + if ($hooks and my $hook = $self->{post_challenge}) { + $hook->($self, $challenge, $resp); + } + + return $resp; +} + + +sub scan { + my $self = shift; + my %args = @_; + + my $limit = delete $args{limit} // 4; + + my @keys; + for (my $device = 0; $device < $limit; ++$device) { + my %info = $self->_get_yubikey_info($device) or last; + + for (my $slot = 1; $slot <= 2; ++$slot) { + my $config = $CONFIG_VALID[$slot] // next; + next unless $info{touch_level} & $config; + + my $key = $self->new(%args, device => $device, slot => $slot, %info); + if ($info{product_id} <= NEO_OTP_U2F_CCID_PID) { + # NEO and earlier always require touch, so forego testing + $key->touch_level($info{touch_level} | $CONFIG_TOUCH[$slot]); + push @keys, $key; + } + else { + eval { $key->challenge('test', timeout => 0) }; + if (my $err = $@) { + my $yk_errno = ref $err && $err->details->{yk_errno} || 0; + if ($yk_errno == YK_EWOULDBLOCK) { + $key->touch_level($info{touch_level} | $CONFIG_TOUCH[$slot]); + } + elsif ($yk_errno != 0) { + # alert $err; + next; + } + } + push @keys, $key; + } + } + } + + return @keys; +} + + +has device => 0; +has slot => 1; +has timeout => 10; +has pre_challenge => undef; +has post_challenge => undef; +has ykchalresp => sub { $ENV{YKCHALRESP} || 'ykchalresp' }; +has ykinfo => sub { $ENV{YKINFO} || 'ykinfo' }; + + +has serial => sub { $_[0]->_set_yubikey_info; $_[0]->{serial} }; +has version => sub { $_[0]->_set_yubikey_info; $_[0]->{version} }; +has touch_level => sub { $_[0]->_set_yubikey_info; $_[0]->{touch_level} }; +has vendor_id => sub { $_[0]->_set_yubikey_info; $_[0]->{vendor_id} }; +has product_id => sub { $_[0]->_set_yubikey_info; $_[0]->{product_id} }; + + +sub name { + my $self = shift; + my $name = _product_name($self->vendor_id, $self->product_id // return); + my $serial = $self->serial; + my $version = $self->version || '?'; + my $slot = $self->slot; + my $touch = $self->requires_interaction ? ' - Interaction required' : ''; + return sprintf('%s v%s [%d] (slot #%d)', $name, $version, $serial, $slot); +} + + +sub requires_interaction { + my $self = shift; + my $touch = $self->touch_level // return; + return $touch & $CONFIG_TOUCH[$self->slot]; +} + +############################################################################## + +### Call ykinfo to get some information about a YubiKey +sub _get_yubikey_info { + my $self = shift; + my $device = shift; + + my $timeout = $self->timeout; + my @cmd = ($self->_program('ykinfo'), "-n$device", qw{-a}); + + my $r; + my $try = 0; + TRY: + { + $r = $self->_run_ykpers(\@cmd, { + (0 < $timeout ? (timeout => $timeout) : ()), + terminate_on_parent_sudden_death => 1, + }); + + my $exit_code = $r->{exit_code}; + if ($exit_code != 0) { + my $err = $r->{stderr}; + chomp $err; + my $yk_errno = _yk_errno($err); + return if $yk_errno == YK_ENOKEY; + if ($yk_errno == YK_EWOULDBLOCK && ++$try <= $RETRY_COUNT) { + sleep $RETRY_INTERVAL; + goto TRY; + } + alert 'Failed to get YubiKey device info: ' . ($err ? $err : 'Something happened'), + error => $err, + yk_errno => $yk_errno || 0; + return; + } + } + + my $out = $r->{stdout}; + chomp $out; + if (!$out) { + alert 'Failed to get YubiKey device info: no output'; + return; + } + + my %info = map { $_ => ($out =~ /^\Q$_\E: (.+)$/m)[0] } + qw(serial version touch_level vendor_id product_id); + $info{vendor_id} = hex($info{vendor_id}) if defined $info{vendor_id}; + $info{product_id} = hex($info{product_id}) if defined $info{product_id}; + + return %info; +} + +### Set the YubiKey information as attributes of a Key object +sub _set_yubikey_info { + my $self = shift; + my %info = $self->_get_yubikey_info($self->device); + @$self{keys %info} = values %info; +} + +sub _program { + my $self = shift; + my $name = shift; + my @cmd = $self->$name // $name; + my $name_uc = uc($name); + my $flags = $ENV{"${name_uc}_FLAGS"}; + push @cmd, split(/\h+/, $flags) if $flags; + return @cmd; +} + +sub _run_ykpers { + my $self = shift; + my $ppid = $$; + my $r = eval { run_forked(@_) }; + my $err = $@; + if ($$ != $ppid) { + # Work around IPC::Cmd bug where child can return from run_forked. + # https://rt.cpan.org/Public/Bug/Display.html?id=127372 + require POSIX; + POSIX::_exit(0); + } + if ($err || ($r->{exit_code} == 0 && $r->{err_msg} eq '' && $r->{stdout} eq '' && $r->{stderr} eq '')) { + $err //= 'No output'; + my $prog = $_[0][0]; + throw "Failed to run $prog - Make sure you have the YubiKey Personalization Tool (CLI) package installed.\n", + error => $err; + } + return $r; +} + +sub _yk_errno { + local $_ = shift or return 0; + return YK_EUSBERR if $_ =~ YK_EUSBERR; + return YK_EWRONGSIZ if $_ =~ YK_EWRONGSIZ; + return YK_EWRITEERR if $_ =~ YK_EWRITEERR; + return YK_ETIMEOUT if $_ =~ YK_ETIMEOUT; + return YK_ENOKEY if $_ =~ YK_ENOKEY; + return YK_EFIRMWARE if $_ =~ YK_EFIRMWARE; + return YK_ENOMEM if $_ =~ YK_ENOMEM; + return YK_ENOSTATUS if $_ =~ YK_ENOSTATUS; + return YK_ENOTYETIMPL if $_ =~ YK_ENOTYETIMPL; + return YK_ECHECKSUM if $_ =~ YK_ECHECKSUM; + return YK_EWOULDBLOCK if $_ =~ YK_EWOULDBLOCK; + return YK_EINVALIDCMD if $_ =~ YK_EINVALIDCMD; + return YK_EMORETHANONE if $_ =~ YK_EMORETHANONE; + return YK_ENODATA if $_ =~ YK_ENODATA; + return -1; +} + +my %PIDS; +for my $pid ( + YUBIKEY_PID, NEO_OTP_PID, NEO_OTP_CCID_PID, NEO_CCID_PID, NEO_U2F_PID, NEO_OTP_U2F_PID, NEO_U2F_CCID_PID, + NEO_OTP_U2F_CCID_PID, YK4_OTP_PID, YK4_U2F_PID, YK4_OTP_U2F_PID, YK4_CCID_PID, YK4_OTP_CCID_PID, + YK4_U2F_CCID_PID, YK4_OTP_U2F_CCID_PID, PLUS_U2F_OTP_PID, ONLYKEY_PID, +) { + $PIDS{$pid} = $PIDS{0+$pid} = $pid; +} +sub _product_name { $PIDS{$_[1]} // 'Unknown' } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Key::YubiKey - A Yubico challenge-response key + +=head1 VERSION + +version 0.800 + +=head1 SYNOPSIS + + use File::KDBX::Key::YubiKey; + use File::KDBX; + + my $yubikey = File::KDBX::Key::YubiKey->new(%attributes); + + my $kdbx = File::KDBX->load_file('database.kdbx', $yubikey); + # OR + my $kdbx = File::KDBX->load_file('database.kdbx', ['password', $yubikey]); + + # Scan for USB YubiKeys: + my ($first_key, @other_keys) = File::KDBX::Key::YubiKey->scan; + + my $response = $first_key->challenge('hello'); + +=head1 DESCRIPTION + +A L<File::KDBX::Key::YubiKey> is a type of challenge-response key. This module follows the KeePassXC-style +challenge-response implementation, so this might not work at all with incompatible challenge-response +implementations (e.g. KeeChallenge). + +Inherets methods and attributes from L<File::KDBX::Key::ChallengeResponse>. + +To use this type of key to secure a L<File::KDBX> database, you also need to install the +L<YubiKey Personalization Tool (CLI)|https://developers.yubico.com/yubikey-personalization/> and configure at +least one of the slots on your YubiKey for HMAC-SHA1 challenge response mode. You can use the YubiKey +Personalization Tool GUI to do this. + +See L<https://keepassxc.org/docs/#faq-yubikey-howto> for more information. + +=head1 ATTRIBUTES + +=head2 device + + $device = $key->device($device); + +Get or set the device number, which is the index number starting and incrementing from zero assigned +to the YubiKey device. If there is only one detected YubiKey device, it's number is C<0>. + +Defaults to C<0>. + +=head2 slot + + $slot = $key->slot($slot); + +Get or set the slot number, which is a number starting and incrementing from one. A YubiKey can have +multiple slots (often just two) which can be independently configured. + +Defaults to C<1>. + +=head2 timeout + + $timeout = $key->timeout($timeout); + +Get or set the timeout, in seconds. If the challenge takes longer than this, the challenge will be +cancelled and an error is thrown. + +If the timeout is zero, the challenge is non-blocking; an error is thrown if the challenge would +block. If the timeout is negative, timeout is disabled and the challenge will block forever or until +a response is received. + +Defaults to C<0>. + +=head2 pre_challenge + + $callback = $key->pre_challenge($callback); + +Get or set a callback function that will be called immediately before any challenge is issued. This might be +used to prompt the user so they are aware that they are expected to interact with their YubiKey. + + $key->pre_challenge(sub { + my ($key, $challenge) = @_; + + if ($key->requires_interaction) { + say 'Please touch your key device to proceed with decrypting your KDBX file.'; + } + say 'Key: ', $key->name; + if (0 < $key->timeout) { + say 'Key access request expires: ' . localtime(time + $key->timeout); + } + }); + +You can throw from this subroutine to abort the challenge. If the challenge is part of loading or dumping +a KDBX database, the entire load/dump will be aborted. + +=head2 post_challenge + + $callback = $key->post_challenge($callback); + +Get or set a callback function that will be called immediately after a challenge response has been received. + +You can throw from this subroutine to abort the challenge. If the challenge is part of loading or dumping +a KDBX database, the entire load/dump will be aborted. + +=head2 ykchalresp + + $program = $key->ykchalresp; + +Get or set the L<ykchalresp(1)> program name or filepath. Defaults to C<$ENV{YKCHALRESP}> or C<ykchalresp>. + +=head2 ykinfo + + $program = $key->ykinfo; + +Get or set the L<ykinfo(1)> program name or filepath. Defaults to C<$ENV{YKINFO}> or C<ykinfo>. + +=head1 METHODS + +=head2 scan + + @keys = File::KDBX::Key::YubiKey->scan(%options); + +Find connected, configured YubiKeys that are capable of responding to a challenge. This can take several +second. + +Options: + +=over 4 + +=item * + +C<limit> - Scan for only up to this many YubiKeys (default: 4) + +=back + +Other options are passed as-is as attributes to the key constructors of found keys (if any). + +=head2 serial + +Get the device serial number, as a number, or C<undef> if there is no such device. + +=head2 version + +Get the device firmware version (or C<undef>). + +=head2 touch_level + +Get the "touch level" value for the device associated with this key (or C<undef>). + +=head2 vendor_id + +=head2 product_id + +Get the vendor ID or product ID for the device associated with this key (or C<undef>). + +=head2 name + + $name = $key->name; + +Get a human-readable string identifying the YubiKey (or C<undef>). + +=head2 requires_interaction + +Get whether or not the key requires interaction (e.g. a touch) to provide a challenge response (or C<undef>). + +=head1 ENVIRONMENT + +=over 4 + +=item * + +C<YKCHALRESP> - Path to the L<ykchalresp(1)> program + +=item * + +C<YKINFO> - Path to the L<ykinfo(1)> program + +=item * + +C<YKCHALRESP_FLAGS> - Extra arguments to the B<ykchalresp(1)> program + +=item * + +C<YKINFO_FLAGS> - Extra arguments to the B<ykinfo(1)> program + +=back + +B<YubiKey> searches for these programs in the same way perl typically searches for executables (using the +C<PATH> environment variable on many platforms). If the programs aren't installed normally, or if you want to +override the default programs, these environment variables can be used. + +=head1 CAVEATS + +This doesn't work yet on Windows, probably. The hangup is pretty silly: IPC. Theoretically it would work if +C<run_forked> from L<IPC::Cmd> worked in Windows, but it probably doesn't. I spent a couple hours applying +various quirks to L<IPC::Open3> and L<IPC::Cmd> implementations but never quite got it to worked reliably +without deadlocks. Maybe I'll revisit this later. Hit me up so I know if there's demand. + +It would also be possible to implement this is an XS module that incorporated ykcore, using libusb-1 which +would probably make it more portable with Windows. Perhaps if I get around to it. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Loader.pm b/lib/File/KDBX/Loader.pm new file mode 100644 index 0000000..209a2a6 --- /dev/null +++ b/lib/File/KDBX/Loader.pm @@ -0,0 +1,422 @@ +package File::KDBX::Loader; +# ABSTRACT: Load KDBX files + +use warnings; +use strict; + +use File::KDBX::Constants qw(:magic :header :version); +use File::KDBX::Error; +use File::KDBX::Util qw(:class :io); +use File::KDBX; +use IO::Handle; +use Module::Load (); +use Ref::Util qw(is_ref is_scalarref); +use Scalar::Util qw(looks_like_number openhandle); +use namespace::clean; + +our $VERSION = '0.800'; # VERSION + + +sub new { + my $class = shift; + my $self = bless {}, $class; + $self->init(@_); +} + + +sub init { + my $self = shift; + my %args = @_; + + @$self{keys %args} = values %args; + + return $self; +} + +sub _rebless { + my $self = shift; + my $format = shift // $self->format; + + my $sig2 = $self->kdbx->sig2; + my $version = $self->kdbx->version; + + my $subclass; + + if (defined $format) { + $subclass = $format; + } + elsif (defined $sig2 && $sig2 == KDBX_SIG2_1) { + $subclass = 'KDB'; + } + elsif (looks_like_number($version)) { + my $major = $version & KDBX_VERSION_MAJOR_MASK; + my %subclasses = ( + KDBX_VERSION_2_0() => 'V3', + KDBX_VERSION_3_0() => 'V3', + KDBX_VERSION_4_0() => 'V4', + ); + $subclass = $subclasses{$major} + or throw sprintf('Unsupported KDBX file version: %x', $version), version => $version; + } + else { + throw sprintf('Unknown file version: %s', $version), version => $version; + } + + Module::Load::load "File::KDBX::Loader::$subclass"; + bless $self, "File::KDBX::Loader::$subclass"; +} + + +sub reset { + my $self = shift; + %$self = (); + return $self; +} + + +sub load { + my $self = shift; + my $src = shift; + return $self->load_handle($src, @_) if openhandle($src) || $src eq '-'; + return $self->load_string($src, @_) if is_scalarref($src); + return $self->load_file($src, @_) if !is_ref($src) && defined $src; + throw 'Programmer error: Must pass a stringref, filepath or IO handle to read'; +} + + +sub load_string { + my $self = shift; + my $str = shift or throw 'Expected string to load'; + my %args = @_ % 2 == 0 ? @_ : (key => shift, @_); + + my $key = delete $args{key}; + $args{kdbx} //= $self->kdbx; + + my $ref = is_scalarref($str) ? $str : \$str; + + open(my $fh, '<', $ref) or throw "Failed to open string buffer: $!"; + + $self = $self->new if !ref $self; + $self->init(%args, fh => $fh)->_read($fh, $key); + return $args{kdbx}; +} + + +sub load_file { + my $self = shift; + my $filepath = shift; + my %args = @_ % 2 == 0 ? @_ : (key => shift, @_); + + my $key = delete $args{key}; + $args{kdbx} //= $self->kdbx; + + open(my $fh, '<:raw', $filepath) or throw 'Open file failed', filepath => $filepath; + + $self = $self->new if !ref $self; + $self->init(%args, fh => $fh, filepath => $filepath)->_read($fh, $key); + return $args{kdbx}; +} + + +sub load_handle { + my $self = shift; + my $fh = shift; + my %args = @_ % 2 == 0 ? @_ : (key => shift, @_); + + $fh = *STDIN if $fh eq '-'; + + my $key = delete $args{key}; + $args{kdbx} //= $self->kdbx; + + $self = $self->new if !ref $self; + $self->init(%args, fh => $fh)->_read($fh, $key); + return $args{kdbx}; +} + + +sub kdbx { + my $self = shift; + return File::KDBX->new if !ref $self; + $self->{kdbx} = shift if @_; + $self->{kdbx} //= File::KDBX->new; +} + + +has format => undef, is => 'ro'; +has inner_format => 'XML', is => 'ro'; + + +sub min_version { KDBX_VERSION_OLDEST } + + +sub read_magic_numbers { + my $self = shift; + my $fh = shift; + my $kdbx = shift // $self->kdbx; + + read_all $fh, my $magic, 12 or throw 'Failed to read file signature'; + + my ($sig1, $sig2, $version) = unpack('L<3', $magic); + + if ($kdbx) { + $kdbx->sig1($sig1); + $kdbx->sig2($sig2); + $kdbx->version($version); + $self->_rebless if ref $self; + } + + return wantarray ? ($sig1, $sig2, $version, $magic) : $magic; +} + +sub _fh { $_[0]->{fh} or throw 'IO handle not set' } + +sub _read { + my $self = shift; + my $fh = shift; + my $key = shift; + + my $kdbx = $self->kdbx; + $key //= $kdbx->key ? $kdbx->key->reload : undef; + $kdbx->reset; + + read_all $fh, my $buf, 1 or throw 'Failed to read the first byte', type => 'parser'; + my $first = ord($buf); + $fh->ungetc($first); + if ($first != KDBX_SIG1_FIRST_BYTE) { + # not a KDBX file... try skipping the outer layer + return $self->_read_inner_body($fh); + } + + my $magic = $self->read_magic_numbers($fh, $kdbx); + $kdbx->sig1 == KDBX_SIG1 or throw 'Invalid file signature', type => 'parser', sig1 => $kdbx->sig1; + + if (ref($self) =~ /::(?:KDB|V[34])$/) { + defined $key or throw 'Must provide a master key', type => 'key.missing'; + } + + my $headers = $self->_read_headers($fh); + + eval { + $self->_read_body($fh, $key, "$magic$headers"); + }; + if (my $err = $@) { + throw "Failed to load KDBX file: $err", + error => $err, + compression_error => $IO::Uncompress::Gunzip::GunzipError, + crypt_error => $File::KDBX::IO::Crypt::ERROR, + hash_error => $File::KDBX::IO::HashBLock::ERROR, + hmac_error => $File::KDBX::IO::HmacBLock::ERROR; + } +} + +sub _read_headers { + my $self = shift; + my $fh = shift; + + my $headers = $self->kdbx->headers; + my $all_raw = ''; + + while (my ($type, $val, $raw) = $self->_read_header($fh)) { + $all_raw .= $raw; + last if $type == HEADER_END; + $headers->{$type} = $val; + } + + return $all_raw; +} + +sub _read_body { die "Not implemented" } + +sub _read_inner_body { + my $self = shift; + + my $current_pkg = ref $self; + require Scope::Guard; + my $guard = Scope::Guard->new(sub { bless $self, $current_pkg }); + + $self->_rebless($self->inner_format); + $self->_read_inner_body(@_); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Loader - Load KDBX files + +=head1 VERSION + +version 0.800 + +=head1 DESCRIPTION + +=head1 ATTRIBUTES + +=head2 kdbx + + $kdbx = $loader->kdbx; + $loader->kdbx($kdbx); + +Get or set the L<File::KDBX> instance for storing the loaded data into. + +=head2 format + +Get the file format used for reading the database. Normally the format is auto-detected from the data stream. +This auto-detection works well, so there's not really a good reason to explicitly specify the format. +Possible formats: + +=over 4 + +=item * + +C<V3> + +=item * + +C<V4> + +=item * + +C<KDB> + +=item * + +C<XML> + +=item * + +C<Raw> + +=back + +=head2 inner_format + +Get the format of the data inside the KDBX envelope. This only applies to C<V3> and C<V4> formats. Possible +formats: + +=over 4 + +=item * + +C<XML> - Read the database groups and entries as XML (default) + +=item * + +C<Raw> - Read parsing and store the result in L<File::KDBX/raw> + +=back + +=head1 METHODS + +=head2 new + + $loader = File::KDBX::Loader->new(%attributes); + +Construct a new L<File::KDBX::Loader>. + +=head2 init + + $loader = $loader->init(%attributes); + +Initialize a L<File::KDBX::Loader> with a new set of attributes. + +This is called by L</new>. + +=head2 reset + + $loader = $loader->reset; + +Set a L<File::KDBX::Loader> to a blank state, ready to load another KDBX file. + +=head2 load + + $kdbx = File::KDBX::Loader->load(\$string, $key); + $kdbx = File::KDBX::Loader->load(*IO, $key); + $kdbx = File::KDBX::Loader->load($filepath, $key); + $kdbx = $loader->load(...); # also instance method + +Load a KDBX file. + +The C<$key> is either a L<File::KDBX::Key> or a primitive that can be converted to a Key object. + +=head2 load_string + + $kdbx = File::KDBX::Loader->load_string($string, $key); + $kdbx = File::KDBX::Loader->load_string(\$string, $key); + $kdbx = $loader->load_string(...); # also instance method + +Load a KDBX file from a string / memory buffer. + +=head2 load_file + + $kdbx = File::KDBX::Loader->load_file($filepath, $key); + $kdbx = $loader->load_file(...); # also instance method + +Read a KDBX file from a filesystem. + +=head2 load_handle + + $kdbx = File::KDBX::Loader->load_handle($fh, $key); + $kdbx = File::KDBX::Loader->load_handle(*IO, $key); + $kdbx->load_handle(...); # also instance method + +Read a KDBX file from an input stream / file handle. + +=head2 min_version + + $min_version = File::KDBX::Loader->min_version; + +Get the minimum KDBX file version supported, which is 3.0 or C<0x00030000> as +it is encoded. + +To read older KDBX files unsupported by this module, try L<File::KeePass>. + +=head2 read_magic_numbers + + $magic = File::KDBX::Loader->read_magic_numbers($fh); + ($sig1, $sig2, $version, $magic) = File::KDBX::Loader->read_magic_numbers($fh); + + $magic = $loader->read_magic_numbers($fh); + ($sig1, $sig2, $version, $magic) = $loader->read_magic_numbers($fh); + +Read exactly 12 bytes from an IO handle and parse them into the three magic numbers that begin +a KDBX file. This is a quick way to determine if a file is actually a KDBX file. + +C<$sig1> should always be C<KDBX_SIG1> if reading an actual KDB or KDBX file. + +C<$sig2> should be C<KDBX_SIG2_1> for KeePass 1 files and C<KDBX_SIG2_2> for KeePass 2 files. + +C<$version> is the file version (e.g. C<0x00040001>). + +C<$magic> is the raw 12 bytes read from the IO handle. + +If called on an instance, the C<sig1>, C<sig2> and C<version> attributes will be set in the L</kdbx> +and the instance will be blessed into the correct loader subclass. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Loader/KDB.pm b/lib/File/KDBX/Loader/KDB.pm new file mode 100644 index 0000000..6ab093b --- /dev/null +++ b/lib/File/KDBX/Loader/KDB.pm @@ -0,0 +1,443 @@ +package File::KDBX::Loader::KDB; +# ABSTRACT: Read KDB files + +use warnings; +use strict; + +use Encode qw(encode); +use File::KDBX::Constants qw(:header :cipher :random_stream :icon); +use File::KDBX::Error; +use File::KDBX::Util qw(:class :empty :io :uuid load_optional); +use File::KDBX; +use Ref::Util qw(is_arrayref is_hashref); +use Scalar::Util qw(looks_like_number); +use Time::Piece; +use boolean; +use namespace::clean; + +extends 'File::KDBX::Loader'; + +our $VERSION = '0.800'; # VERSION + +my $DEFAULT_EXPIRATION = Time::Piece->new(32503677839); # 2999-12-31 23:59:59 + +sub _read_headers { '' } + +sub _read_body { + my $self = shift; + my $fh = shift; + my $key = shift; + my $buf = shift; + + load_optional('File::KeePass'); + + $buf .= do { local $/; <$fh> }; + + $key = $self->kdbx->composite_key($key, keep_primitive => 1); + + my $k = eval { File::KeePass->new->parse_db(\$buf, _convert_kdbx_to_keepass_master_key($key)) }; + if (my $err = $@) { + throw 'Failed to parse KDB file', error => $err; + } + + $k->unlock; + $self->kdbx->key($key); + + return convert_keepass_to_kdbx($k, $self->kdbx); +} + +# This is also used by File::KDBX::Dumper::KDB. +sub _convert_kdbx_to_keepass_master_key { + my $key = shift; + + my @keys = @{$key->keys}; + if (@keys == 1 && !$keys[0]->can('filepath')) { + return [encode('CP-1252', $keys[0]->{primitive})]; # just a password + } + elsif (@keys == 1) { + return [undef, \$keys[0]->raw_key]; # just a keyfile + } + elsif (@keys == 2 && !$keys[0]->can('filepath') && $keys[1]->can('filepath')) { + return [encode('CP-1252', $keys[0]->{primitive}), \$keys[1]->raw_key]; + } + throw 'Cannot use this key to load a KDB file', key => $key; +} + + +sub convert_keepass_to_kdbx { + my $k = shift; + my $kdbx = shift // File::KDBX->new; + + $kdbx->{headers} //= {}; + _convert_keepass_to_kdbx_headers($k->{header}, $kdbx); + + my @groups = @{$k->{groups} || []}; + if (@groups == 1) { + $kdbx->{root} = _convert_keepass_to_kdbx_group($k->{groups}[0]); + } + elsif (1 < @groups) { + my $root = $kdbx->{root} = {%{File::KDBX->_implicit_root}}; + for my $group (@groups) { + push @{$root->{groups} //= []}, _convert_keepass_to_kdbx_group($group); + } + } + + $kdbx->entries + ->grep({ + title => 'Meta-Info', + username => 'SYSTEM', + url => '$', + icon_id => 0, + -nonempty => 'notes', + }) + ->each(sub { + _read_meta_stream($kdbx, $_); + $_->remove(signal => 0); + }); + + return $kdbx; +} + +sub _read_meta_stream { + my $kdbx = shift; + my $entry = shift; + + my $type = $entry->notes; + my $data = $entry->binary_value('bin-stream'); + open(my $fh, '<', \$data) or throw "Failed to open memory buffer for reading: $!"; + + if ($type eq 'KPX_GROUP_TREE_STATE') { + read_all $fh, my $buf, 4 or goto PARSE_ERROR; + my ($num) = unpack('L<', $buf); + $num * 5 + 4 == length($data) or goto PARSE_ERROR; + for (my $i = 0; $i < $num; ++$i) { + read_all $fh, $buf, 5 or goto PARSE_ERROR; + my ($group_id, $expanded) = unpack('L< C', $buf); + my $uuid = _decode_uuid($group_id) // next; + my $group = $kdbx->groups->grep({uuid => $uuid})->next; + $group->is_expanded($expanded) if $group; + } + } + elsif ($type eq 'KPX_CUSTOM_ICONS_4') { + read_all $fh, my $buf, 12 or goto PARSE_ERROR; + my ($num_icons, $num_entries, $num_groups) = unpack('L<3', $buf); + my @icons; + for (my $i = 0; $i < $num_icons; ++$i) { + read_all $fh, $buf, 4 or goto PARSE_ERROR; + my ($icon_size) = unpack('L<', $buf); + read_all $fh, $buf, $icon_size or goto PARSE_ERROR; + my $uuid = $kdbx->add_custom_icon($buf); + push @icons, $uuid; + } + for (my $i = 0; $i < $num_entries; ++$i) { + read_all $fh, $buf, 20 or goto PARSE_ERROR; + my ($uuid, $icon_index) = unpack('a16 L<', $buf); + next if !$icons[$icon_index]; + my $entry = $kdbx->entries->grep({uuid => $uuid})->next; + $entry->custom_icon_uuid($icons[$icon_index]) if $entry; + } + for (my $i = 0; $i < $num_groups; ++$i) { + read_all $fh, $buf, 8 or goto PARSE_ERROR; + my ($group_id, $icon_index) = unpack('L<2', $buf); + next if !$icons[$icon_index]; + my $uuid = _decode_uuid($group_id) // next; + my $group = $kdbx->groups->grep({uuid => $uuid})->next; + $group->custom_icon_uuid($icons[$icon_index]) if $group; + } + } + else { + alert "Ignoring unknown meta stream: $type\n", type => $type; + return; + } + + return; + + PARSE_ERROR: + alert "Ignoring unparsable meta stream: $type\n", type => $type; +} + +sub _convert_keepass_to_kdbx_headers { + my $from = shift; + my $kdbx = shift; + + my $headers = $kdbx->{headers} //= {}; + my $meta = $kdbx->{meta} //= {}; + + $kdbx->{sig1} = $from->{sig1}; + $kdbx->{sig2} = $from->{sig2}; + $kdbx->{version} = $from->{vers}; + + my %enc_type = ( + rijndael => CIPHER_UUID_AES256, + aes => CIPHER_UUID_AES256, + twofish => CIPHER_UUID_TWOFISH, + chacha20 => CIPHER_UUID_CHACHA20, + salsa20 => CIPHER_UUID_SALSA20, + serpent => CIPHER_UUID_SERPENT, + ); + my $cipher_uuid = $enc_type{$from->{cipher} || ''} // $enc_type{$from->{enc_type} || ''}; + + my %protected_stream = ( + rc4 => STREAM_ID_RC4_VARIANT, + salsa20 => STREAM_ID_SALSA20, + chacha20 => STREAM_ID_CHACHA20, + ); + my $protected_stream_id = $protected_stream{$from->{protected_stream} || ''} || STREAM_ID_SALSA20; + + $headers->{+HEADER_COMMENT} = $from->{comment}; + $headers->{+HEADER_CIPHER_ID} = $cipher_uuid if $cipher_uuid; + $headers->{+HEADER_MASTER_SEED} = $from->{seed_rand}; + $headers->{+HEADER_COMPRESSION_FLAGS} = $from->{compression} // 0; + $headers->{+HEADER_TRANSFORM_SEED} = $from->{seed_key}; + $headers->{+HEADER_TRANSFORM_ROUNDS} = $from->{rounds}; + $headers->{+HEADER_ENCRYPTION_IV} = $from->{enc_iv}; + $headers->{+HEADER_INNER_RANDOM_STREAM_ID} = $protected_stream_id; + $headers->{+HEADER_INNER_RANDOM_STREAM_KEY} = $from->{protected_stream_key}; + $headers->{+HEADER_STREAM_START_BYTES} = $from->{start_bytes} // ''; + + # TODO for KeePass 1 files these are all not available. Leave undefined or set default values? + $meta->{memory_protection}{protect_notes} = boolean($from->{protect_notes}); + $meta->{memory_protection}{protect_password} = boolean($from->{protect_password}); + $meta->{memory_protection}{protect_username} = boolean($from->{protect_username}); + $meta->{memory_protection}{protect_url} = boolean($from->{protect_url}); + $meta->{memory_protection}{protect_title} = boolean($from->{protect_title}); + $meta->{generator} = $from->{generator} // ''; + $meta->{header_hash} = $from->{header_hash}; + $meta->{database_name} = $from->{database_name} // ''; + $meta->{database_name_changed} = _decode_datetime($from->{database_name_changed}); + $meta->{database_description} = $from->{database_description} // ''; + $meta->{database_description_changed} = _decode_datetime($from->{database_description_changed}); + $meta->{default_username} = $from->{default_user_name} // ''; + $meta->{default_username_changed} = _decode_datetime($from->{default_user_name_changed}); + $meta->{maintenance_history_days} = $from->{maintenance_history_days}; + $meta->{color} = $from->{color}; + $meta->{master_key_changed} = _decode_datetime($from->{master_key_changed}); + $meta->{master_key_change_rec} = $from->{master_key_change_rec}; + $meta->{master_key_change_force} = $from->{master_key_change_force}; + $meta->{recycle_bin_enabled} = boolean($from->{recycle_bin_enabled}); + $meta->{recycle_bin_uuid} = $from->{recycle_bin_uuid}; + $meta->{recycle_bin_changed} = _decode_datetime($from->{recycle_bin_changed}); + $meta->{entry_templates_group} = $from->{entry_templates_group}; + $meta->{entry_templates_group_changed} = _decode_datetime($from->{entry_templates_group_changed}); + $meta->{last_selected_group} = $from->{last_selected_group}; + $meta->{last_top_visible_group} = $from->{last_top_visible_group}; + $meta->{history_max_items} = $from->{history_max_items}; + $meta->{history_max_size} = $from->{history_max_size}; + $meta->{settings_changed} = _decode_datetime($from->{settings_changed}); + + while (my ($key, $value) = each %{$from->{custom_icons} || {}}) { + push @{$meta->{custom_icons} //= []}, {uuid => $key, data => $value}; + } + while (my ($key, $value) = each %{$from->{custom_data} || {}}) { + $meta->{custom_data}{$key} = {value => $value}; + } + + return $kdbx; +} + +sub _convert_keepass_to_kdbx_group { + my $from = shift; + my $to = shift // {}; + my %args = @_; + + $to->{times}{last_access_time} = _decode_datetime($from->{accessed}); + $to->{times}{usage_count} = $from->{usage_count} || 0; + $to->{times}{expiry_time} = _decode_datetime($from->{expires}, $DEFAULT_EXPIRATION); + $to->{times}{expires} = defined $from->{expires_enabled} + ? boolean($from->{expires_enabled}) + : boolean($to->{times}{expiry_time} <= gmtime); + $to->{times}{creation_time} = _decode_datetime($from->{created}); + $to->{times}{last_modification_time} = _decode_datetime($from->{modified}); + $to->{times}{location_changed} = _decode_datetime($from->{location_changed}); + $to->{notes} = $from->{notes} // ''; + $to->{uuid} = _decode_uuid($from->{id}); + $to->{is_expanded} = boolean($from->{expanded}); + $to->{icon_id} = $from->{icon} // ICON_FOLDER; + $to->{name} = $from->{title} // ''; + $to->{default_auto_type_sequence} = $from->{auto_type_default} // ''; + $to->{enable_auto_type} = _decode_tristate($from->{auto_type_enabled}); + $to->{enable_searching} = _decode_tristate($from->{enable_searching}); + $to->{groups} = []; + $to->{entries} = []; + + if (!$args{shallow}) { + for my $group (@{$from->{groups} || []}) { + push @{$to->{groups}}, _convert_keepass_to_kdbx_group($group); + } + for my $entry (@{$from->{entries} || []}) { + push @{$to->{entries}}, _convert_keepass_to_kdbx_entry($entry); + } + } + + return $to; +} + +sub _convert_keepass_to_kdbx_entry { + my $from = shift; + my $to = shift // {}; + my %args = @_; + + $to->{times}{last_access_time} = _decode_datetime($from->{accessed}); + $to->{times}{usage_count} = $from->{usage_count} || 0; + $to->{times}{expiry_time} = _decode_datetime($from->{expires}, $DEFAULT_EXPIRATION); + $to->{times}{expires} = defined $from->{expires_enabled} + ? boolean($from->{expires_enabled}) + : boolean($to->{times}{expiry_time} <= gmtime); + $to->{times}{creation_time} = _decode_datetime($from->{created}); + $to->{times}{last_modification_time} = _decode_datetime($from->{modified}); + $to->{times}{location_changed} = _decode_datetime($from->{location_changed}); + + $to->{auto_type}{data_transfer_obfuscation} = $from->{auto_type_munge} || false; + $to->{auto_type}{enabled} = boolean($from->{auto_type_enabled} // 1); + + my $comment = $from->{comment}; + my @auto_type = is_arrayref($from->{auto_type}) ? @{$from->{auto_type}} : (); + + if (!@auto_type && nonempty $from->{auto_type} && nonempty $from->{auto_type_window} + && !is_hashref($from->{auto_type})) { + @auto_type = ({window => $from->{auto_type_window}, keys => $from->{auto_type}}); + } + if (nonempty $comment) { + my @AT; + my %atw = my @atw = $comment =~ m{ ^Auto-Type-Window((?:-?\d+)?): [\t ]* (.*?) [\t ]*$ }mxg; + my %atk = my @atk = $comment =~ m{ ^Auto-Type((?:-?\d+)?): [\t ]* (.*?) [\t ]*$ }mxg; + $comment =~ s{ ^Auto-Type(?:-Window)?(?:-?\d+)?: .* \n? }{}mxg; + while (@atw) { + my ($n, $w) = (shift(@atw), shift(@atw)); + push @AT, {window => $w, keys => exists($atk{$n}) ? $atk{$n} : $atk{''}}; + } + while (@atk) { + my ($n, $k) = (shift(@atk), shift(@atk)); + push @AT, {keys => $k, window => exists($atw{$n}) ? $atw{$n} : $atw{''}}; + } + for (@AT) { + $_->{'window'} //= ''; + $_->{'keys'} //= ''; + } + my %uniq; + @AT = grep {!$uniq{"$_->{'window'}\e$_->{'keys'}"}++} @AT; + push @auto_type, @AT; + } + $to->{auto_type}{associations} = [ + map { +{window => $_->{window}, keystroke_sequence => $_->{keys}} } @auto_type, + ]; + + $to->{strings}{Notes}{value} = $comment; + $to->{strings}{UserName}{value} = $from->{username}; + $to->{strings}{Password}{value} = $from->{password}; + $to->{strings}{URL}{value} = $from->{url}; + $to->{strings}{Title}{value} = $from->{title}; + $to->{strings}{Notes}{protect} = true if defined $from->{protected}{comment}; + $to->{strings}{UserName}{protect} = true if defined $from->{protected}{username}; + $to->{strings}{Password}{protect} = true if $from->{protected}{password} // 1; + $to->{strings}{URL}{protect} = true if defined $from->{protected}{url}; + $to->{strings}{Title}{protect} = true if defined $from->{protected}{title}; + + # other strings + while (my ($key, $value) = each %{$from->{strings} || {}}) { + $to->{strings}{$key} = { + value => $value, + $from->{protected}{$key} ? (protect => true) : (), + }; + } + + $to->{override_url} = $from->{override_url}; + $to->{tags} = $from->{tags} // ''; + $to->{icon_id} = $from->{icon} // ICON_PASSWORD; + $to->{uuid} = _decode_uuid($from->{id}); + $to->{foreground_color} = $from->{foreground_color} // ''; + $to->{background_color} = $from->{background_color} // ''; + $to->{custom_icon_uuid} = $from->{custom_icon_uuid}; + $to->{history} = []; + + local $from->{binary} = {$from->{binary_name} => $from->{binary}} + if nonempty $from->{binary} && nonempty $from->{binary_name} && !is_hashref($from->{binary}); + while (my ($key, $value) = each %{$from->{binary} || {}}) { + $to->{binaries}{$key} = {value => $value}; + } + + if (!$args{shallow}) { + for my $entry (@{$from->{history} || []}) { + my $new_entry = {}; + push @{$to->{entries}}, _convert_keepass_to_kdbx_entry($entry, $new_entry); + } + } + + return $to; +} + +sub _decode_datetime { + local $_ = shift // return shift // gmtime; + return Time::Piece->strptime($_, '%Y-%m-%d %H:%M:%S'); +} + +sub _decode_uuid { + local $_ = shift // return; + # Group IDs in KDB files are 32-bit integers + return sprintf('%016x', $_) if length($_) != 16 && looks_like_number($_); + return $_; +} + +sub _decode_tristate { + local $_ = shift // return; + return boolean($_); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Loader::KDB - Read KDB files + +=head1 VERSION + +version 0.800 + +=head1 DESCRIPTION + +Read older KDB (KeePass 1) files. This feature requires an additional module to be installed: + +=over 4 + +=item * + +L<File::KeePass> + +=back + +=head1 FUNCTIONS + +=head2 convert_keepass_to_kdbx + + $kdbx = convert_keepass_to_kdbx($keepass); + $kdbx = convert_keepass_to_kdbx($keepass, $kdbx); + +Convert a L<File::KeePass> to a L<File::KDBX>. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Loader/Raw.pm b/lib/File/KDBX/Loader/Raw.pm new file mode 100644 index 0000000..5409578 --- /dev/null +++ b/lib/File/KDBX/Loader/Raw.pm @@ -0,0 +1,86 @@ +package File::KDBX::Loader::Raw; +# ABSTRACT: A no-op loader that doesn't do any parsing + +use warnings; +use strict; + +use File::KDBX::Util qw(:class); +use namespace::clean; + +extends 'File::KDBX::Loader'; + +our $VERSION = '0.800'; # VERSION + +sub _read { + my $self = shift; + my $fh = shift; + + $self->_read_body($fh); +} + +sub _read_body { + my $self = shift; + my $fh = shift; + + $self->_read_inner_body($fh); +} + +sub _read_inner_body { + my $self = shift; + my $fh = shift; + + my $content = do { local $/; <$fh> }; + $self->kdbx->raw($content); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Loader::Raw - A no-op loader that doesn't do any parsing + +=head1 VERSION + +version 0.800 + +=head1 SYNOPSIS + + use File::KDBX::Loader; + + my $kdbx = File::KDBX::Loader->load_file('file.kdbx', $key, inner_format => 'Raw'); + print $kdbx->raw; + +=head1 DESCRIPTION + +A typical KDBX file is made up of an outer section (with headers) and an inner section (with the body). The +inner section is usually loaded using L<File::KDBX::Loader::XML>, but you can use the +B<File::KDBX::Loader::Raw> loader to not parse the body at all and just get the raw body content. This can be +useful for debugging or creating KDBX files with arbitrary content (see L<File::KDBX::Dumper::Raw>). + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Loader/V3.pm b/lib/File/KDBX/Loader/V3.pm new file mode 100644 index 0000000..4d10a75 --- /dev/null +++ b/lib/File/KDBX/Loader/V3.pm @@ -0,0 +1,200 @@ +package File::KDBX::Loader::V3; +# ABSTRACT: Load KDBX3 files + +# magic +# headers +# body +# CRYPT( +# start bytes +# HASH( +# COMPRESS( +# xml +# ) +# ) +# ) + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use Encode qw(decode); +use File::KDBX::Constants qw(:header :compression :kdf); +use File::KDBX::Error; +use File::KDBX::IO::Crypt; +use File::KDBX::IO::HashBlock; +use File::KDBX::Util qw(:class :io :load assert_64bit erase_scoped); +use namespace::clean; + +extends 'File::KDBX::Loader'; + +our $VERSION = '0.800'; # VERSION + +sub _read_header { + my $self = shift; + my $fh = shift; + + read_all $fh, my $buf, 3 or throw 'Malformed header field, expected header type and size'; + my ($type, $size) = unpack('C S<', $buf); + + my $val; + if (0 < $size) { + read_all $fh, $val, $size or throw 'Expected header value', type => $type, size => $size; + $buf .= $val; + } + + $type = to_header_constant($type); + if ($type == HEADER_END) { + # done + } + elsif ($type == HEADER_COMMENT) { + $val = decode('UTF-8', $val); + } + elsif ($type == HEADER_CIPHER_ID) { + $size == 16 or throw 'Invalid cipher UUID length', got => $size, expected => $size; + } + elsif ($type == HEADER_COMPRESSION_FLAGS) { + $val = unpack('L<', $val); + } + elsif ($type == HEADER_MASTER_SEED) { + $size == 32 or throw 'Invalid master seed length', got => $size, expected => $size; + } + elsif ($type == HEADER_TRANSFORM_SEED) { + # nothing + } + elsif ($type == HEADER_TRANSFORM_ROUNDS) { + assert_64bit; + $val = unpack('Q<', $val); + } + elsif ($type == HEADER_ENCRYPTION_IV) { + # nothing + } + elsif ($type == HEADER_INNER_RANDOM_STREAM_KEY) { + # nothing + } + elsif ($type == HEADER_STREAM_START_BYTES) { + # nothing + } + elsif ($type == HEADER_INNER_RANDOM_STREAM_ID) { + $val = unpack('L<', $val); + } + elsif ($type == HEADER_KDF_PARAMETERS || + $type == HEADER_PUBLIC_CUSTOM_DATA) { + throw "Unexpected KDBX4 header: $type", type => $type; + } + else { + alert "Unknown header: $type", type => $type; + } + + return wantarray ? ($type => $val, $buf) : $buf; +} + +sub _read_body { + my $self = shift; + my $fh = shift; + my $key = shift; + my $header_data = shift; + my $kdbx = $self->kdbx; + + # assert all required headers present + for my $field ( + HEADER_CIPHER_ID, + HEADER_ENCRYPTION_IV, + HEADER_MASTER_SEED, + HEADER_INNER_RANDOM_STREAM_KEY, + HEADER_STREAM_START_BYTES, + ) { + defined $kdbx->headers->{$field} or throw "Missing $field"; + } + + $kdbx->kdf_parameters({ + KDF_PARAM_UUID() => KDF_UUID_AES, + KDF_PARAM_AES_ROUNDS() => delete $kdbx->headers->{+HEADER_TRANSFORM_ROUNDS}, + KDF_PARAM_AES_SEED() => delete $kdbx->headers->{+HEADER_TRANSFORM_SEED}, + }); + + my $master_seed = $kdbx->headers->{+HEADER_MASTER_SEED}; + + my @cleanup; + $key = $kdbx->composite_key($key); + + my $response = $key->challenge($master_seed); + push @cleanup, erase_scoped $response; + + my $transformed_key = $kdbx->kdf->transform($key); + push @cleanup, erase_scoped $transformed_key; + + my $final_key = digest_data('SHA256', $master_seed, $response, $transformed_key); + push @cleanup, erase_scoped $final_key; + + my $cipher = $kdbx->cipher(key => $final_key); + $fh = File::KDBX::IO::Crypt->new($fh, cipher => $cipher); + + read_all $fh, my $start_bytes, 32 or throw 'Failed to read starting bytes'; + + my $expected_start_bytes = $kdbx->headers->{stream_start_bytes}; + $start_bytes eq $expected_start_bytes + or throw "Invalid credentials or data is corrupt (wrong starting bytes)\n", + got => $start_bytes, expected => $expected_start_bytes, headers => $kdbx->headers; + + $kdbx->key($key); + + $fh = File::KDBX::IO::HashBlock->new($fh); + + my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS}; + if ($compress == COMPRESSION_GZIP) { + load_optional('IO::Uncompress::Gunzip'); + $fh = IO::Uncompress::Gunzip->new($fh) + or throw "Failed to initialize compression library: $IO::Uncompress::Gunzip::GunzipError", + error => $IO::Uncompress::Gunzip::GunzipError; + } + elsif ($compress != COMPRESSION_NONE) { + throw "Unsupported compression ($compress)\n", compression_flags => $compress; + } + + $self->_read_inner_body($fh); + close($fh); + + if (my $header_hash = $kdbx->meta->{header_hash}) { + my $got_header_hash = digest_data('SHA256', $header_data); + $header_hash eq $got_header_hash + or throw 'Header hash does not match', got => $got_header_hash, expected => $header_hash; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Loader::V3 - Load KDBX3 files + +=head1 VERSION + +version 0.800 + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Loader/V4.pm b/lib/File/KDBX/Loader/V4.pm new file mode 100644 index 0000000..4db30e7 --- /dev/null +++ b/lib/File/KDBX/Loader/V4.pm @@ -0,0 +1,300 @@ +package File::KDBX::Loader::V4; +# ABSTRACT: Load KDBX4 files + +# magic +# headers +# headers checksum +# headers hmac +# body +# HMAC( +# CRYPT( +# COMPRESS( +# xml +# ) +# ) +# ) + +use warnings; +use strict; + +use Crypt::Digest qw(digest_data); +use Crypt::Mac::HMAC qw(hmac); +use Encode qw(decode); +use File::KDBX::Constants qw(:header :inner_header :variant_map :compression); +use File::KDBX::Error; +use File::KDBX::Util qw(:class :io :load assert_64bit erase_scoped); +use File::KDBX::IO::Crypt; +use File::KDBX::IO::HmacBlock; +use boolean; +use namespace::clean; + +extends 'File::KDBX::Loader'; + +our $VERSION = '0.800'; # VERSION + +sub _read_header { + my $self = shift; + my $fh = shift; + + read_all $fh, my $buf, 5 or throw 'Malformed header field, expected header type and size'; + my ($type, $size) = unpack('C L<', $buf); + + my $val; + if (0 < $size) { + read_all $fh, $val, $size or throw 'Expected header value', type => $type, size => $size; + $buf .= $val; + } + + $type = to_header_constant($type); + if ($type == HEADER_END) { + # done + } + elsif ($type == HEADER_COMMENT) { + $val = decode('UTF-8', $val); + } + elsif ($type == HEADER_CIPHER_ID) { + $size == 16 or throw 'Invalid cipher UUID length', got => $size, expected => $size; + } + elsif ($type == HEADER_COMPRESSION_FLAGS) { + $val = unpack('L<', $val); + } + elsif ($type == HEADER_MASTER_SEED) { + $size == 32 or throw 'Invalid master seed length', got => $size, expected => $size; + } + elsif ($type == HEADER_ENCRYPTION_IV) { + # nothing + } + elsif ($type == HEADER_KDF_PARAMETERS) { + open(my $dict_fh, '<', \$val); + $val = $self->_read_variant_dictionary($dict_fh); + } + elsif ($type == HEADER_PUBLIC_CUSTOM_DATA) { + open(my $dict_fh, '<', \$val); + $val = $self->_read_variant_dictionary($dict_fh); + } + elsif ($type == HEADER_INNER_RANDOM_STREAM_ID || + $type == HEADER_INNER_RANDOM_STREAM_KEY || + $type == HEADER_TRANSFORM_SEED || + $type == HEADER_TRANSFORM_ROUNDS || + $type == HEADER_STREAM_START_BYTES) { + throw "Unexpected KDBX3 header: $type", type => $type; + } + else { + alert "Unknown header: $type", type => $type; + } + + return wantarray ? ($type => $val, $buf) : $buf; +} + +sub _read_variant_dictionary { + my $self = shift; + my $fh = shift; + + read_all $fh, my $buf, 2 or throw 'Failed to read variant dictionary version'; + my ($version) = unpack('S<', $buf); + VMAP_VERSION == ($version & VMAP_VERSION_MAJOR_MASK) + or throw 'Unsupported variant dictionary version', version => $version; + + my %dict; + + while (1) { + read_all $fh, $buf, 1 or throw 'Failed to read variant type'; + my ($type) = unpack('C', $buf); + last if $type == VMAP_TYPE_END; # terminating null + + read_all $fh, $buf, 4 or throw 'Failed to read variant key size'; + my ($klen) = unpack('L<', $buf); + + read_all $fh, my $key, $klen or throw 'Failed to read variant key'; + + read_all $fh, $buf, 4 or throw 'Failed to read variant size'; + my ($vlen) = unpack('L<', $buf); + + read_all $fh, my $val, $vlen or throw 'Failed to read variant'; + + if ($type == VMAP_TYPE_UINT32) { + ($val) = unpack('L<', $val); + } + elsif ($type == VMAP_TYPE_UINT64) { + assert_64bit; + ($val) = unpack('Q<', $val); + } + elsif ($type == VMAP_TYPE_BOOL) { + ($val) = unpack('C', $val); + $val = boolean($val); + } + elsif ($type == VMAP_TYPE_INT32) { + ($val) = unpack('l<', $val); + } + elsif ($type == VMAP_TYPE_INT64) { + assert_64bit; + ($val) = unpack('q<', $val); + } + elsif ($type == VMAP_TYPE_STRING) { + $val = decode('UTF-8', $val); + } + elsif ($type == VMAP_TYPE_BYTEARRAY) { + # nothing + } + else { + throw 'Unknown variant type', type => $type; + } + $dict{$key} = $val; + } + + return \%dict; +} + +sub _read_body { + my $self = shift; + my $fh = shift; + my $key = shift; + my $header_data = shift; + my $kdbx = $self->kdbx; + + # assert all required headers present + for my $field ( + HEADER_CIPHER_ID, + HEADER_ENCRYPTION_IV, + HEADER_MASTER_SEED, + ) { + defined $kdbx->headers->{$field} or throw "Missing $field"; + } + + my @cleanup; + + # checksum check + read_all $fh, my $header_hash, 32 or throw 'Failed to read header hash'; + my $got_header_hash = digest_data('SHA256', $header_data); + $got_header_hash eq $header_hash + or throw 'Data is corrupt (header checksum mismatch)', + got => $got_header_hash, expected => $header_hash; + + $key = $kdbx->composite_key($key); + my $transformed_key = $kdbx->kdf->transform($key); + push @cleanup, erase_scoped $transformed_key; + + # authentication check + read_all $fh, my $header_hmac, 32 or throw 'Failed to read header HMAC'; + my $hmac_key = digest_data('SHA512', $kdbx->headers->{master_seed}, $transformed_key, "\x01"); + push @cleanup, erase_scoped $hmac_key; + my $got_header_hmac = hmac('SHA256', + digest_data('SHA512', "\xff\xff\xff\xff\xff\xff\xff\xff", $hmac_key), + $header_data, + ); + $got_header_hmac eq $header_hmac + or throw "Invalid credentials or data is corrupt (header HMAC mismatch)\n", + got => $got_header_hmac, expected => $header_hmac; + + $kdbx->key($key); + + $fh = File::KDBX::IO::HmacBlock->new($fh, key => $hmac_key); + + my $final_key = digest_data('SHA256', $kdbx->headers->{master_seed}, $transformed_key); + push @cleanup, erase_scoped $final_key; + + my $cipher = $kdbx->cipher(key => $final_key); + $fh = File::KDBX::IO::Crypt->new($fh, cipher => $cipher); + + my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS}; + if ($compress == COMPRESSION_GZIP) { + load_optional('IO::Uncompress::Gunzip'); + $fh = IO::Uncompress::Gunzip->new($fh) + or throw "Failed to initialize compression library: $IO::Uncompress::Gunzip::GunzipError", + error => $IO::Uncompress::Gunzip::GunzipError; + } + elsif ($compress != COMPRESSION_NONE) { + throw "Unsupported compression ($compress)\n", compression_flags => $compress; + } + + $self->_read_inner_headers($fh); + $self->_read_inner_body($fh); +} + +sub _read_inner_headers { + my $self = shift; + my $fh = shift; + + while (my ($type, $val) = $self->_read_inner_header($fh)) { + last if $type == INNER_HEADER_END; + } +} + +sub _read_inner_header { + my $self = shift; + my $fh = shift; + my $kdbx = $self->kdbx; + + read_all $fh, my $buf, 5 or throw 'Expected inner header type and size'; + my ($type, $size) = unpack('C L<', $buf); + + my $val; + if (0 < $size) { + read_all $fh, $val, $size or throw 'Expected inner header value', type => $type, size => $size; + } + + $type = to_inner_header_constant($type) // $type; + if ($type == INNER_HEADER_END) { + # nothing + } + elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_ID) { + $val = unpack('L<', $val); + $kdbx->inner_headers->{$type} = $val; + } + elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_KEY) { + $kdbx->inner_headers->{$type} = $val; + } + elsif ($type == INNER_HEADER_BINARY) { + my $msize = $size - 1; + my ($flags, $data) = unpack("C a$msize", $val); + my $id = scalar keys %{$kdbx->binaries}; + $kdbx->binaries->{$id} = { + value => $data, + $flags & INNER_HEADER_BINARY_FLAG_PROTECT ? (protect => true) : (), + }; + } + else { + alert "Ignoring unknown inner header type ($type)", type => $type, size => $size, value => $val; + return wantarray ? ($type => $val) : $type; + } + + return wantarray ? ($type => $val) : $type; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Loader::V4 - Load KDBX4 files + +=head1 VERSION + +version 0.800 + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Loader/XML.pm b/lib/File/KDBX/Loader/XML.pm new file mode 100644 index 0000000..1243114 --- /dev/null +++ b/lib/File/KDBX/Loader/XML.pm @@ -0,0 +1,616 @@ +package File::KDBX::Loader::XML; +# ABSTRACT: Load unencrypted XML KeePass files + +use warnings; +use strict; + +use Crypt::Misc 0.029 qw(decode_b64); +use Encode qw(decode); +use File::KDBX::Constants qw(:version :time); +use File::KDBX::Error; +use File::KDBX::Safe; +use File::KDBX::Util qw(:class :text assert_64bit gunzip erase_scoped); +use Scalar::Util qw(looks_like_number); +use Time::Piece; +use XML::LibXML::Reader; +use boolean; +use namespace::clean; + +extends 'File::KDBX::Loader'; + +our $VERSION = '0.800'; # VERSION + +has '_reader', is => 'ro'; +has '_safe', is => 'ro', default => sub { File::KDBX::Safe->new(cipher => $_[0]->kdbx->random_stream) }; + +sub _read { + my $self = shift; + my $fh = shift; + + $self->_read_inner_body($fh); +} + +sub _read_inner_body { + my $self = shift; + my $fh = shift; + + my $reader = $self->{_reader} = XML::LibXML::Reader->new(IO => $fh); + + delete $self->{_safe}; + my $root_done; + + my $pattern = XML::LibXML::Pattern->new('/KeePassFile/Meta|/KeePassFile/Root'); + while ($reader->nextPatternMatch($pattern) == 1) { + next if $reader->nodeType != XML_READER_TYPE_ELEMENT; + my $name = $reader->localName; + if ($name eq 'Meta') { + $self->_read_xml_meta; + } + elsif ($name eq 'Root') { + if ($root_done) { + alert 'Ignoring extra Root element in KeePass XML file', line => $reader->lineNumber; + next; + } + $self->_read_xml_root; + $root_done = 1; + } + } + + if ($reader->readState == XML_READER_ERROR) { + throw 'Failed to parse KeePass XML'; + } + + $self->kdbx->_safe($self->_safe) if $self->{_safe}; + + $self->_resolve_binary_refs; +} + +sub _read_xml_meta { + my $self = shift; + + $self->_read_xml_element($self->kdbx->meta, + Generator => 'text', + HeaderHash => 'binary', + DatabaseName => 'text', + DatabaseNameChanged => 'datetime', + DatabaseDescription => 'text', + DatabaseDescriptionChanged => 'datetime', + DefaultUserName => 'text', + DefaultUserNameChanged => 'datetime', + MaintenanceHistoryDays => 'number', + Color => 'text', + MasterKeyChanged => 'datetime', + MasterKeyChangeRec => 'number', + MasterKeyChangeForce => 'number', + MemoryProtection => \&_read_xml_memory_protection, + CustomIcons => \&_read_xml_custom_icons, + RecycleBinEnabled => 'bool', + RecycleBinUUID => 'uuid', + RecycleBinChanged => 'datetime', + EntryTemplatesGroup => 'uuid', + EntryTemplatesGroupChanged => 'datetime', + LastSelectedGroup => 'uuid', + LastTopVisibleGroup => 'uuid', + HistoryMaxItems => 'number', + HistoryMaxSize => 'number', + SettingsChanged => 'datetime', + Binaries => \&_read_xml_binaries, + CustomData => \&_read_xml_custom_data, + ); +} + +sub _read_xml_memory_protection { + my $self = shift; + my $meta = shift // $self->kdbx->meta; + + return $self->_read_xml_element( + ProtectTitle => 'bool', + ProtectUserName => 'bool', + ProtectPassword => 'bool', + ProtectURL => 'bool', + ProtectNotes => 'bool', + AutoEnableVisualHiding => 'bool', + ); +} + +sub _read_xml_binaries { + my $self = shift; + my $kdbx = $self->kdbx; + + my $binaries = $self->_read_xml_element( + Binary => sub { + my $self = shift; + my $id = $self->_read_xml_attribute('ID'); + my $compressed = $self->_read_xml_attribute('Compressed', 'bool', false); + my $protected = $self->_read_xml_attribute('Protected', 'bool', false); + my $data = $self->_read_xml_content('binary'); + + my $binary = { + value => $data, + $protected ? (protect => true) : (), + }; + + if ($protected) { + # if compressed, decompress later when the safe is unlocked + $self->_safe->add_protected($compressed ? \&gunzip : (), $binary); + } + elsif ($compressed) { + $binary->{value} = gunzip($data); + } + + $id => $binary; + }, + ); + + $kdbx->binaries({%{$kdbx->binaries}, %$binaries}); + return (); # do not add to meta +} + +sub _read_xml_custom_data { + my $self = shift; + + return $self->_read_xml_element( + Item => sub { + my $self = shift; + my $item = $self->_read_xml_element( + Key => 'text', + Value => 'text', + LastModificationTime => 'datetime', # KDBX4.1 + ); + $item->{key} => $item; + }, + ); +} + +sub _read_xml_custom_icons { + my $self = shift; + + return $self->_read_xml_element([], + Icon => sub { + my $self = shift; + $self->_read_xml_element( + UUID => 'uuid', + Data => 'binary', + Name => 'text', # KDBX4.1 + LastModificationTime => 'datetime', # KDBX4.1 + ); + }, + ); +} + +sub _read_xml_root { + my $self = shift; + my $kdbx = $self->kdbx; + + my $root = $self->_read_xml_element( + Group => \&_read_xml_group, + DeletedObjects => \&_read_xml_deleted_objects, + ); + + $kdbx->deleted_objects($root->{deleted_objects}); + $kdbx->root($root->{group}) if $root->{group}; +} + +sub _read_xml_group { + my $self = shift; + + return $self->_read_xml_element({entries => [], groups => []}, + UUID => 'uuid', + Name => 'text', + Notes => 'text', + Tags => 'text', # KDBX4.1 + IconID => 'number', + CustomIconUUID => 'uuid', + Times => \&_read_xml_times, + IsExpanded => 'bool', + DefaultAutoTypeSequence => 'text', + EnableAutoType => 'tristate', + EnableSearching => 'tristate', + LastTopVisibleEntry => 'uuid', + CustomData => \&_read_xml_custom_data, # KDBX4 + PreviousParentGroup => 'uuid', # KDBX4.1 + Entry => [entries => \&_read_xml_entry], + Group => [groups => \&_read_xml_group], + ); +} + +sub _read_xml_entry { + my $self = shift; + + my $entry = $self->_read_xml_element({strings => [], binaries => []}, + UUID => 'uuid', + IconID => 'number', + CustomIconUUID => 'uuid', + ForegroundColor => 'text', + BackgroundColor => 'text', + OverrideURL => 'text', + Tags => 'text', + Times => \&_read_xml_times, + AutoType => \&_read_xml_entry_auto_type, + PreviousParentGroup => 'uuid', # KDBX4.1 + QualityCheck => 'bool', # KDBX4.1 + String => [strings => \&_read_xml_entry_string], + Binary => [binaries => \&_read_xml_entry_binary], + CustomData => \&_read_xml_custom_data, # KDBX4 + History => sub { + my $self = shift; + return $self->_read_xml_element([], + Entry => \&_read_xml_entry, + ); + }, + ); + + my %strings; + for my $string (@{$entry->{strings} || []}) { + $strings{$string->{key}} = $string->{value}; + } + $entry->{strings} = \%strings; + + my %binaries; + for my $binary (@{$entry->{binaries} || []}) { + $binaries{$binary->{key}} = $binary->{value}; + } + $entry->{binaries} = \%binaries; + + return $entry; +} + +sub _read_xml_times { + my $self = shift; + + return $self->_read_xml_element( + LastModificationTime => 'datetime', + CreationTime => 'datetime', + LastAccessTime => 'datetime', + ExpiryTime => 'datetime', + Expires => 'bool', + UsageCount => 'number', + LocationChanged => 'datetime', + ); +} + +sub _read_xml_entry_string { + my $self = shift; + + return $self->_read_xml_element( + Key => 'text', + Value => sub { + my $self = shift; + + my $protected = $self->_read_xml_attribute('Protected', 'bool', false); + my $protect_in_memory = $self->_read_xml_attribute('ProtectInMemory', 'bool', false); + my $protect = $protected || $protect_in_memory; + + my $val = $self->_read_xml_content($protected ? 'binary' : 'text'); + + my $string = { + value => $val, + $protect ? (protect => true) : (), + }; + + $self->_safe->add_protected(sub { decode('UTF-8', $_[0]) }, $string) if $protected; + + $string; + }, + ); +} + +sub _read_xml_entry_binary { + my $self = shift; + + return $self->_read_xml_element( + Key => 'text', + Value => sub { + my $self = shift; + + my $ref = $self->_read_xml_attribute('Ref'); + my $compressed = $self->_read_xml_attribute('Compressed', 'bool', false); + my $protected = $self->_read_xml_attribute('Protected', 'bool', false); + my $binary = {}; + + if (defined $ref) { + $binary->{ref} = $ref; + } + else { + $binary->{value} = $self->_read_xml_content('binary'); + $binary->{protect} = true if $protected; + + if ($protected) { + # if compressed, decompress later when the safe is unlocked + $self->_safe->add_protected($compressed ? \&gunzip : (), $binary); + } + elsif ($compressed) { + $binary->{value} = gunzip($binary->{value}); + } + } + + $binary; + }, + ); +} + +sub _read_xml_entry_auto_type { + my $self = shift; + + return $self->_read_xml_element({associations => []}, + Enabled => 'bool', + DataTransferObfuscation => 'number', + DefaultSequence => 'text', + Association => [associations => sub { + my $self = shift; + return $self->_read_xml_element( + Window => 'text', + KeystrokeSequence => 'text', + ); + }], + ); +} + +sub _read_xml_deleted_objects { + my $self = shift; + + return $self->_read_xml_element( + DeletedObject => sub { + my $self = shift; + my $object = $self->_read_xml_element( + UUID => 'uuid', + DeletionTime => 'datetime', + ); + $object->{uuid} => $object; + } + ); +} + +############################################################################## + +sub _resolve_binary_refs { + my $self = shift; + my $kdbx = $self->kdbx; + + my $pool = $kdbx->binaries; + + my $entries = $kdbx->entries(history => 1); + while (my $entry = $entries->next) { + while (my ($key, $binary) = each %{$entry->binaries}) { + my $ref = $binary->{ref} // next; + next if defined $binary->{value}; + + my $data = $pool->{$ref}; + if (!defined $data || !defined $data->{value}) { + alert "Found a reference to a missing binary: $key", key => $key, ref => $ref; + next; + } + $binary->{value} = $data->{value}; + $binary->{protect} = true if $data->{protect}; + delete $binary->{ref}; + } + } +} + +############################################################################## + +sub _read_xml_element { + my $self = shift; + my $args = @_ % 2 == 1 ? shift : {}; + my %spec = @_; + + my $reader = $self->_reader; + my $path = $reader->nodePath; + $path =~ s!\Q/text()\E$!!; + + return $args if $reader->isEmptyElement; + + my $store = ref $args eq 'CODE' ? $args + : ref $args eq 'HASH' ? sub { + my ($key, $val) = @_; + if (ref $args->{$key} eq 'HASH') { + $args->{$key}{$key} = $val; + } + elsif (ref $args->{$key} eq 'ARRAY') { + push @{$args->{$key}}, $val; + } + else { + exists $args->{$key} + and alert 'Overwriting value', node => $reader->nodePath, line => $reader->lineNumber; + $args->{$key} = $val; + } + } : ref $args eq 'ARRAY' ? sub { + my ($key, $val) = @_; + push @$args, $val; + } : sub {}; + + my $pattern = XML::LibXML::Pattern->new("${path}|${path}/*"); + while ($reader->nextPatternMatch($pattern) == 1) { + last if $reader->nodePath eq $path && $reader->nodeType == XML_READER_TYPE_END_ELEMENT; + next if $reader->nodeType != XML_READER_TYPE_ELEMENT; + + my $name = $reader->localName; + my $key = snakify($name); + my $type = $spec{$name}; + ($key, $type) = @$type if ref $type eq 'ARRAY'; + + if (!defined $type) { + exists $spec{$name} or alert "Ignoring unknown element: $name", + node => $reader->nodePath, + line => $reader->lineNumber; + next; + } + + if (ref $type eq 'CODE') { + my @result = $self->$type($args, $reader->nodePath); + if (@result == 2) { + $store->(@result); + } + elsif (@result == 1) { + $store->($key, @result); + } + } + else { + $store->($key, $self->_read_xml_content($type)); + } + } + + return $args; +} + +sub _read_xml_attribute { + my $self = shift; + my $name = shift; + my $type = shift // 'text'; + my $default = shift; + my $reader = $self->_reader; + + return $default if !$reader->hasAttributes; + + my $value = trim($reader->getAttribute($name)); + if (!defined $value) { + # try again after reading in all the attributes + $reader->moveToFirstAttribute; + while ($self->_reader->readAttributeValue == 1) {} + $reader->moveToElement; + + $value = trim($reader->getAttribute($name)); + } + + return $default if !defined $value; + + my $decoded = eval { _decode_primitive($value, $type) }; + if (my $err = $@) { + ref $err and $err->details(attribute => $name, node => $reader->nodePath, line => $reader->lineNumber); + throw $err + } + + return $decoded; +} + +sub _read_xml_content { + my $self = shift; + my $type = shift; + my $reader = $self->_reader; + + $reader->read if !$reader->isEmptyElement; # step into element + return '' if !$reader->hasValue; + + my $content = trim($reader->value); + + my $decoded = eval { _decode_primitive($content, $type) }; + if (my $err = $@) { + ref $err and $err->details(node => $reader->nodePath, line => $reader->lineNumber); + throw $err + } + + return $decoded; +} + +############################################################################## + +sub _decode_primitive { goto &{__PACKAGE__."::_decode_$_[1]"} } + +sub _decode_binary { + local $_ = shift; + return '' if !defined || (ref && !defined $$_); + $_ = eval { decode_b64(ref $_ ? $$_ : $_) }; + my $err = $@; + my $cleanup = erase_scoped $_; + $err and throw 'Failed to parse binary', error => $err; + return $_; +} + +sub _decode_bool { + local $_ = shift; + return true if /^True$/i; + return false if /^False$/i; + return false if length($_) == 0; + throw 'Expected boolean', text => $_; +} + +sub _decode_datetime { + local $_ = shift; + + if (/^[A-Za-z0-9\+\/\=]+$/) { + my $binary = eval { decode_b64($_) }; + if (my $err = $@) { + throw 'Failed to parse binary datetime', text => $_, error => $err; + } + throw $@ if $@; + assert_64bit; + $binary .= \0 x (8 - length($binary)) if length($binary) < 8; + my ($seconds_since_ad1) = unpack('Q<', $binary); + my $epoch = $seconds_since_ad1 - TIME_SECONDS_AD1_TO_UNIX_EPOCH; + return Time::Piece->new($epoch); + } + + + my $dt = eval { Time::Piece->strptime($_, '%Y-%m-%dT%H:%M:%SZ') }; + if (my $err = $@) { + throw 'Failed to parse datetime', text => $_, error => $err; + } + return $dt; +} + +sub _decode_tristate { + local $_ = shift; + return undef if /^null$/i; + my $tristate = eval { _decode_bool($_) }; + $@ and throw 'Expected tristate', text => $_, error => $@; + return $tristate; +} + +sub _decode_number { + local $_ = shift; + $_ = _decode_text($_); + looks_like_number($_) or throw 'Expected number', text => $_; + return $_+0; +} + +sub _decode_text { + local $_ = shift; + return '' if !defined; + return $_; +} + +sub _decode_uuid { + local $_ = shift; + my $uuid = eval { _decode_binary($_) }; + $@ and throw 'Expected UUID', text => $_, error => $@; + length($uuid) == 16 or throw 'Invalid UUID size', size => length($uuid); + return $uuid; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Loader::XML - Load unencrypted XML KeePass files + +=head1 VERSION + +version 0.800 + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Object.pm b/lib/File/KDBX/Object.pm new file mode 100644 index 0000000..cdf0ca4 --- /dev/null +++ b/lib/File/KDBX/Object.pm @@ -0,0 +1,937 @@ +package File::KDBX::Object; +# ABSTRACT: A KDBX database object + +use warnings; +use strict; + +use Devel::GlobalDestruction; +use File::KDBX::Constants qw(:bool); +use File::KDBX::Error; +use File::KDBX::Util qw(:uuid); +use Hash::Util::FieldHash qw(fieldhashes); +use List::Util qw(any first); +use Ref::Util qw(is_arrayref is_plain_arrayref is_plain_hashref is_ref); +use Scalar::Util qw(blessed weaken); +use namespace::clean; + +our $VERSION = '0.800'; # VERSION + +fieldhashes \my (%KDBX, %PARENT, %TXNS, %REFS, %SIGNALS); + + +sub new { + my $class = shift; + + # copy constructor + return $_[0]->clone if @_ == 1 && blessed $_[0] && $_[0]->isa($class); + + my $data; + $data = shift if is_plain_hashref($_[0]); + + my $kdbx; + $kdbx = shift if @_ % 2 == 1; + + my %args = @_; + $args{kdbx} //= $kdbx if defined $kdbx; + + my $self = bless $data // {}, $class; + $self->init(%args); + $self->_set_nonlazy_attributes if !$data; + return $self; +} + +sub _set_nonlazy_attributes { die 'Not implemented' } + + +sub init { + my $self = shift; + my %args = @_; + + while (my ($key, $val) = each %args) { + if (my $method = $self->can($key)) { + $self->$method($val); + } + } + + return $self; +} + + +sub wrap { + my $class = shift; + my $object = shift; + return $object if blessed $object && $object->isa($class); + return $class->new(@_, @$object) if is_arrayref($object); + return $class->new($object, @_); +} + + +sub label { die 'Not implemented' } + + +my %CLONE = (entries => 1, groups => 1, history => 1); +sub clone { + my $self = shift; + my %args = @_; + + local $CLONE{new_uuid} = $args{new_uuid} // $args{parent} // 0; + local $CLONE{entries} = $args{entries} // 1; + local $CLONE{groups} = $args{groups} // 1; + local $CLONE{history} = $args{history} // 1; + local $CLONE{reference_password} = $args{reference_password} // 0; + local $CLONE{reference_username} = $args{reference_username} // 0; + + require Storable; + my $copy = Storable::dclone($self); + + if ($args{relabel} and my $label = $self->label) { + $copy->label("$label - Copy"); + } + if ($args{parent} and my $parent = $self->group) { + $parent->add_object($copy); + } + + return $copy; +} + +sub STORABLE_freeze { + my $self = shift; + my $cloning = shift; + + my $copy = {%$self}; + delete $copy->{entries} if !$CLONE{entries}; + delete $copy->{groups} if !$CLONE{groups}; + delete $copy->{history} if !$CLONE{history}; + + return ($cloning ? Hash::Util::FieldHash::id($self) : ''), $copy; +} + +sub STORABLE_thaw { + my $self = shift; + my $cloning = shift; + my $addr = shift; + my $copy = shift; + + @$self{keys %$copy} = values %$copy; + + if ($cloning) { + my $kdbx = $KDBX{$addr}; + $self->kdbx($kdbx) if $kdbx; + } + + if (defined $self->{uuid}) { + if (($CLONE{reference_password} || $CLONE{reference_username}) && $self->can('strings')) { + my $uuid = format_uuid($self->{uuid}); + my $clone_obj = do { + local $CLONE{new_uuid} = 0; + local $CLONE{entries} = 1; + local $CLONE{groups} = 1; + local $CLONE{history} = 1; + local $CLONE{reference_password} = 0; + local $CLONE{reference_username} = 0; + # Clone only the entry's data and manually bless to avoid infinite recursion. + bless Storable::dclone({%$copy}), 'File::KDBX::Entry'; + }; + my $txn = $self->begin_work(snapshot => $clone_obj); + if ($CLONE{reference_password}) { + $self->password("{REF:P\@I:$uuid}"); + } + if ($CLONE{reference_username}) { + $self->username("{REF:U\@I:$uuid}"); + } + $txn->commit; + } + $self->uuid(generate_uuid) if $CLONE{new_uuid}; + } + + # Dualvars aren't cloned as dualvars, so dualify the icon. + $self->icon_id($self->{icon_id}) if defined $self->{icon_id}; +} + + +sub kdbx { + my $self = shift; + $self = $self->new if !ref $self; + if (@_) { + if (my $kdbx = shift) { + $KDBX{$self} = $kdbx; + weaken $KDBX{$self}; + } + else { + delete $KDBX{$self}; + } + } + $KDBX{$self} or throw 'Object is disconnected', object => $self; +} + + +sub is_connected { + my $self = shift; + return !!eval { $self->kdbx }; +} + + +sub id { format_uuid(shift->uuid, @_) } + + +sub group { + my $self = shift; + + if (my $new_group = shift) { + my $old_group = $self->group; + return $new_group if Hash::Util::FieldHash::id($old_group) == Hash::Util::FieldHash::id($new_group); + # move to a new parent + $self->remove(signal => 0) if $old_group; + $self->location_changed('now'); + $new_group->add_object($self); + } + + my $id = Hash::Util::FieldHash::id($self); + if (my $group = $PARENT{$self}) { + my $method = $self->_parent_container; + return $group if first { $id == Hash::Util::FieldHash::id($_) } @{$group->$method}; + delete $PARENT{$self}; + } + # always get lineage from root to leaf because the other way requires parent, so it would be recursive + my $lineage = $self->kdbx->_trace_lineage($self) or return; + my $group = pop @$lineage or return; + $PARENT{$self} = $group; weaken $PARENT{$self}; + return $group; +} + +sub _set_group { + my $self = shift; + if (my $parent = shift) { + $PARENT{$self} = $parent; + weaken $PARENT{$self}; + } + else { + delete $PARENT{$self}; + } + return $self; +} + +### Name of the parent attribute expected to contain the object +sub _parent_container { die 'Not implemented' } + + +sub lineage { + my $self = shift; + my $base = shift; + + my $base_addr = $base ? Hash::Util::FieldHash::id($base) : 0; + + # try leaf to root + my @path; + my $object = $self; + while ($object = $object->group) { + unshift @path, $object; + last if $base_addr == Hash::Util::FieldHash::id($object); + } + return \@path if @path && ($base_addr == Hash::Util::FieldHash::id($path[0]) || $path[0]->is_root); + + # try root to leaf + return $self->kdbx->_trace_lineage($self, $base); +} + + +sub remove { + my $self = shift; + my $parent = $self->group; + $parent->remove_object($self, @_) if $parent; + $self->_set_group(undef); + return $self; +} + + +sub recycle { + my $self = shift; + return $self->group($self->kdbx->recycle_bin); +} + + +sub recycle_or_remove { + my $self = shift; + my $kdbx = eval { $self->kdbx }; + if ($kdbx && $kdbx->recycle_bin_enabled && !$self->is_recycled) { + $self->recycle; + } + else { + $self->remove; + } +} + + +sub is_recycled { + my $self = shift; + eval { $self->kdbx } or return FALSE; + return !!($self->group && any { $_->is_recycle_bin } @{$self->lineage}); +} + +############################################################################## + + +sub tag_list { + my $self = shift; + return grep { $_ ne '' } split(/[,\.:;]|\s+/, trim($self->tags) // ''); +} + + +sub custom_icon { + my $self = shift; + my $kdbx = $self->kdbx; + if (@_) { + my $img = shift; + my $uuid = defined $img ? $kdbx->add_custom_icon($img, @_) : undef; + $self->icon_id(0) if $uuid; + $self->custom_icon_uuid($uuid); + return $img; + } + return $kdbx->custom_icon_data($self->custom_icon_uuid); +} + + +sub custom_data { + my $self = shift; + $self->{custom_data} = shift if @_ == 1 && is_plain_hashref($_[0]); + return $self->{custom_data} //= {} if !@_; + + my %args = @_ == 2 ? (key => shift, value => shift) + : @_ % 2 == 1 ? (key => shift, @_) : @_; + + if (!$args{key} && !$args{value}) { + my %standard = (key => 1, value => 1, last_modification_time => 1); + my @other_keys = grep { !$standard{$_} } keys %args; + if (@other_keys == 1) { + my $key = $args{key} = $other_keys[0]; + $args{value} = delete $args{$key}; + } + } + + my $key = $args{key} or throw 'Must provide a custom_data key to access'; + + return $self->{custom_data}{$key} = $args{value} if is_plain_hashref($args{value}); + + while (my ($field, $value) = each %args) { + $self->{custom_data}{$key}{$field} = $value; + } + return $self->{custom_data}{$key}; +} + + +sub custom_data_value { + my $self = shift; + my $data = $self->custom_data(@_) // return undef; + return $data->{value}; +} + +############################################################################## + + +sub begin_work { + my $self = shift; + + if (defined wantarray) { + require File::KDBX::Transaction; + return File::KDBX::Transaction->new($self, @_); + } + + my %args = @_; + my $orig = $args{snapshot} // do { + my $c = $self->clone( + entries => $args{entries} // 0, + groups => $args{groups} // 0, + history => $args{history} // 0, + ); + $c->{entries} = $self->{entries} if !$args{entries}; + $c->{groups} = $self->{groups} if !$args{groups}; + $c->{history} = $self->{history} if !$args{history}; + $c; + }; + + my $id = Hash::Util::FieldHash::id($orig); + _save_references($id, $self, $orig); + + $self->_signal_begin_work; + + push @{$self->_txns}, $orig; +} + + +sub commit { + my $self = shift; + my $orig = pop @{$self->_txns} or return $self; + $self->_commit($orig); + my $signals = $self->_signal_commit; + $self->_signal_send($signals) if !$self->_in_txn; + return $self; +} + + +sub rollback { + my $self = shift; + + my $orig = pop @{$self->_txns} or return $self; + + my $id = Hash::Util::FieldHash::id($orig); + _restore_references($id, $orig); + + $self->_signal_rollback; + + return $self; +} + +# Get whether or not there is at least one pending transaction. +sub _in_txn { scalar @{$_[0]->_txns} } + +# Get an array ref of pending transactions. +sub _txns { $TXNS{$_[0]} //= [] } + +# The _commit hook notifies subclasses that a commit has occurred. +sub _commit { die 'Not implemented' } + +# Get a reference to an object that represents an object's committed state. If there is no pending +# transaction, this is just $self. If there is a transaction, this is the snapshot take before the transaction +# began. This method is private because it provides direct access to the actual snapshot. It is important that +# the snapshot not be changed or a rollback would roll back to an altered state. +# This is used by File::KDBX::Dumper::XML so as to not dump uncommitted changes. +sub _committed { + my $self = shift; + my ($orig) = @{$self->_txns}; + return $orig // $self; +} + +# In addition to cloning an object when beginning work, we also keep track its hashrefs and arrayrefs +# internally so that we can restore to the very same structures in the case of a rollback. +sub _save_references { + my $id = shift; + my $self = shift; + my $orig = shift; + + if (is_plain_arrayref($orig)) { + for (my $i = 0; $i < @$orig; ++$i) { + _save_references($id, $self->[$i], $orig->[$i]); + } + $REFS{$id}{Hash::Util::FieldHash::id($orig)} = $self; + } + elsif (is_plain_hashref($orig) || (blessed $orig && $orig->isa(__PACKAGE__))) { + for my $key (keys %$orig) { + _save_references($id, $self->{$key}, $orig->{$key}); + } + $REFS{$id}{Hash::Util::FieldHash::id($orig)} = $self; + } +} + +# During a rollback, copy data from the snapshot back into the original internal structures. +sub _restore_references { + my $id = shift; + my $orig = shift // return; + my $self = delete $REFS{$id}{Hash::Util::FieldHash::id($orig) // ''} // return $orig; + + if (is_plain_arrayref($orig)) { + @$self = map { _restore_references($id, $_) } @$orig; + } + elsif (is_plain_hashref($orig) || (blessed $orig && $orig->isa(__PACKAGE__))) { + for my $key (keys %$orig) { + # next if is_ref($orig->{$key}) && + # (Hash::Util::FieldHash::id($self->{$key}) // 0) == Hash::Util::FieldHash::id($orig->{$key}); + $self->{$key} = _restore_references($id, $orig->{$key}); + } + } + + return $self; +} + +############################################################################## + +sub _signal { + my $self = shift; + my $type = shift; + + if ($self->_in_txn) { + my $stack = $self->_signal_stack; + my $queue = $stack->[-1]; + push @$queue, [$type, @_]; + } + + $self->_signal_send([[$type, @_]]); + + return $self; +} + +sub _signal_stack { $SIGNALS{$_[0]} //= [] } + +sub _signal_begin_work { + my $self = shift; + push @{$self->_signal_stack}, []; +} + +sub _signal_commit { + my $self = shift; + my $signals = pop @{$self->_signal_stack}; + my $previous = $self->_signal_stack->[-1] // []; + push @$previous, @$signals; + return $previous; +} + +sub _signal_rollback { + my $self = shift; + pop @{$self->_signal_stack}; +} + +sub _signal_send { + my $self = shift; + my $signals = shift // []; + + my $kdbx = $KDBX{$self} or return; + + # de-duplicate, keeping the most recent signal for each type + my %seen; + my @signals = grep { !$seen{$_->[0]}++ } reverse @$signals; + + for my $sig (reverse @signals) { + $kdbx->_handle_signal($self, @$sig); + } +} + +############################################################################## + +sub _wrap_group { + my $self = shift; + my $group = shift; + require File::KDBX::Group; + return File::KDBX::Group->wrap($group, $KDBX{$self}); +} + +sub _wrap_entry { + my $self = shift; + my $entry = shift; + require File::KDBX::Entry; + return File::KDBX::Entry->wrap($entry, $KDBX{$self}); +} + +sub TO_JSON { +{%{$_[0]}} } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Object - A KDBX database object + +=head1 VERSION + +version 0.800 + +=head1 DESCRIPTION + +KDBX is an object database. This abstract class represents an object. You should not use this class directly +but instead use its subclasses: + +=over 4 + +=item * + +L<File::KDBX::Entry> + +=item * + +L<File::KDBX::Group> + +=back + +There is some functionality shared by both types of objects, and that's what this class provides. + +Each object can be connected with a L<File::KDBX> database or be disconnected. A disconnected object exists in +memory but will not be persisted when dumping a database. It is also possible for an object to be connected +with a database but not be part of the object tree (i.e. is not the root group or any subroup or entry). +A disconnected object or an object not part of the object tree of a database can be added to a database using +one of: + +=over 4 + +=item * + +L<File::KDBX/add_entry> + +=item * + +L<File::KDBX/add_group> + +=item * + +L<File::KDBX::Group/add_entry> + +=item * + +L<File::KDBX::Group/add_group> + +=item * + +L<File::KDBX::Entry/add_historical_entry> + +=back + +It is possible to copy or move objects between databases, but B<DO NOT> include the same object in more +than one database at once or there could be some strange aliasing effects (i.e. changes in one database might +effect another in unexpected ways). This could lead to difficult-to-debug problems. It is similarly not safe +or valid to add the same object multiple times to the same database. For example: + + my $entry = File::KDBX::Entry->(title => 'Whatever'); + + # DO NOT DO THIS: + $kdbx->add_entry($entry); + $another_kdbx->add_entry($entry); + + # DO NOT DO THIS: + $kdbx->add_entry($entry); + $kdbx->add_entry($entry); # again + +Instead, do this: + + # Copy an entry to multiple databases: + $kdbx->add_entry($entry); + $another_kdbx->add_entry($entry->clone); + + # OR move an existing entry from one database to another: + $another_kdbx->add_entry($entry->remove); + +=head1 ATTRIBUTES + +=head2 kdbx + + $kdbx = $object->kdbx; + $object->kdbx($kdbx); + +Get or set the L<File::KDBX> instance connected with this object. + +=head1 METHODS + +=head2 new + + $object = File::KDBX::Object->new; + $object = File::KDBX::Object->new(%attributes); + $object = File::KDBX::Object->new(\%data); + $object = File::KDBX::Object->new(\%data, $kdbx); + +Construct a new KDBX object. + +There is a subtlety to take note of. There is a significant difference between: + + File::KDBX::Entry->new(username => 'iambatman'); + +and: + + File::KDBX::Entry->new({username => 'iambatman'}); # WRONG + +In the first, an empty object is first created and then initialized with whatever I<attributes> are given. In +the second, a hashref is blessed and essentially becomes the object. The significance is that the hashref +key-value pairs will remain as-is so the structure is expected to adhere to the shape of a raw B<Object> +(which varies based on the type of object), whereas with the first the attributes will set the structure in +the correct way (just like using the object accessors / getters / setters). + +The second example isn't I<generally> wrong -- this type of construction is supported for a reason, to allow +for working with KDBX objects at a low level -- but it is wrong in this specific case only because +C<< {username => $str} >> isn't a valid raw KDBX entry object. The L</username> attribute is really a proxy +for the C<UserName> string, so the equivalent raw entry object should be +C<< {strings => {UserName => {value => $str}}} >>. These are roughly equivalent: + + File::KDBX::Entry->new(username => 'iambatman'); + File::KDBX::Entry->new({strings => {UserName => {value => 'iambatman'}}}); + +If this explanation went over your head, that's fine. Just stick with the attributes since they are typically +easier to use correctly and provide the most convenience. If in the future you think of some kind of KDBX +object manipulation you want to do that isn't supported by the accessors and methods, just know you I<can> +access an object's data directly. + +=head2 init + + $object = $object->init(%attributes); + +Called by the constructor to set attributes. You normally should not call this. + +=head2 wrap + + $object = File::KDBX::Object->wrap($object); + +Ensure that a KDBX object is blessed. + +=head2 label + + $label = $object->label; + $object->label($label); + +Get or set the object's label, a text string that can act as a non-unique identifier. For an entry, the label +is its title string. For a group, the label is its name. + +=head2 clone + + $object_copy = $object->clone(%options); + $object_copy = File::KDBX::Object->new($object); + +Make a clone of an object. By default the clone is indeed an exact copy that is connected to the same database +but not actually included in the object tree (i.e. it has no parent group). Some options are allowed to get +different effects: + +=over 4 + +=item * + +C<new_uuid> - If set, generate a new UUID for the copy (default: false) + +=item * + +C<parent> - If set, add the copy to the same parent group, if any (default: false) + +=item * + +C<relabel> - If set, append " - Copy" to the object's title or name (default: false) + +=item * + +C<entries> - If set, copy child entries, if any (default: true) + +=item * + +C<groups> - If set, copy child groups, if any (default: true) + +=item * + +C<history> - If set, copy entry history, if any (default: true) + +=item * + +C<reference_password> - Toggle whether or not cloned entry's Password string should be set as a field reference to the original entry's Password string (default: false) + +=item * + +C<reference_username> - Toggle whether or not cloned entry's UserName string should be set as a field reference to the original entry's UserName string (default: false) + +=back + +=head2 is_connected + + $bool = $object->is_connected; + +Determine whether or not an object is connected to a database. + +=head2 id + + $string_uuid = $object->id; + $string_uuid = $object->id($delimiter); + +Get the unique identifier for this object as a B<formatted> UUID string, typically for display purposes. You +could use this to compare with other identifiers formatted with the same delimiter, but it is more efficient +to use the raw UUID for that purpose (see L</uuid>). + +A delimiter can optionally be provided to break up the UUID string visually. See +L<File::KDBX::Util/format_uuid>. + +=head2 group + + $parent_group = $object->group; + $object->group($parent_group); + +Get or set the parent group to which an object belongs or C<undef> if it belongs to no group. + +=head2 lineage + + \@lineage = $object->lineage; + \@lineage = $object->lineage($base_group); + +Get the direct line of ancestors from C<$base_group> (default: the root group) to an object. The lineage +includes the base group but I<not> the target object. Returns C<undef> if the target is not in the database +structure. Returns an empty arrayref is the object itself is a root group. + +=head2 remove + + $object = $object->remove(%options); + +Remove an object from its parent. If the object is a group, all contained objects stay with the object and so +are removed as well. Options: + +=over 4 + +=item * + +C<signal> Whether or not to signal the removal to the connected database (default: true) + +=back + +=head2 recycle + + $object = $object->recycle; + +Remove an object from its parent and add it to the connected database's recycle bin group. + +=head2 recycle_or_remove + + $object = $object->recycle_or_remove; + +Recycle or remove an object, depending on the connected database's L<File::KDBX/recycle_bin_enabled>. If the +object is not connected to a database or is already in the recycle bin, remove it. + +=head2 is_recycled + + $bool = $object->is_recycled; + +Get whether or not an object is in a recycle bin. + +=head2 tag_list + + @tags = $entry->tag_list; + +Get a list of tags, split from L</tag> using delimiters C<,>, C<.>, C<:>, C<;> and whitespace. + +=head2 custom_icon + + $image_data = $object->custom_icon; + $image_data = $object->custom_icon($image_data, %attributes); + +Get or set an icon image. Returns C<undef> if there is no custom icon set. Setting a custom icon will change +the L</custom_icon_uuid> attribute. + +Custom icon attributes (supported in KDBX4.1 and greater): + +=over 4 + +=item * + +C<name> - Name of the icon (text) + +=item * + +C<last_modification_time> - Just what it says (datetime) + +=back + +=head2 custom_data + + \%all_data = $object->custom_data; + $object->custom_data(\%all_data); + + \%data = $object->custom_data($key); + $object->custom_data($key => \%data); + $object->custom_data(%data); + $object->custom_data(key => $value, %data); + +Get and set custom data. Custom data is metadata associated with an object. + +Each data item can have a few attributes associated with it. + +=over 4 + +=item * + +C<key> - A unique text string identifier used to look up the data item (required) + +=item * + +C<value> - A text string value (required) + +=item * + +C<last_modification_time> (optional, KDBX4.1+) + +=back + +=head2 custom_data_value + + $value = $object->custom_data_value($key); + +Exactly the same as L</custom_data> except returns just the custom data's value rather than a structure of +attributes. This is a shortcut for: + + my $data = $object->custom_data($key); + my $value = defined $data ? $data->{value} : undef; + +=head2 begin_work + + $txn = $object->begin_work(%options); + $object->begin_work(%options); + +Begin a new transaction. Returns a L<File::KDBX::Transaction> object that can be scoped to ensure a rollback +occurs if exceptions are thrown. Alternatively, if called in void context, there will be no +B<File::KDBX::Transaction> and it is instead your responsibility to call L</commit> or L</rollback> as +appropriate. It is undefined behavior to call these if a B<File::KDBX::Transaction> exists. Recursive +transactions are allowed. + +Signals created during a transaction are delayed until all transactions are resolved. If the outermost +transaction is committed, then the signals are de-duplicated and delivered. Otherwise the signals are dropped. +This means that the KDBX database will not fix broken references or mark itself dirty until after the +transaction is committed. + +How it works: With the beginning of a transaction, a snapshot of the object is created. In the event of +a rollback, the object's data is replaced with data from the snapshot. + +By default, the snapshot is shallow (i.e. does not include subroups, entries or historical entries). This +means that only modifications to the object itself (its data, fields, strings, etc.) are atomic; modifications +to subroups etc., including adding or removing items, are auto-committed instantly and will persist regardless +of the result of the pending transaction. You can override this for groups, entries and history independently +using options: + +=over 4 + +=item * + +C<entries> - If set, snapshot entries within a group, deeply (default: false) + +=item * + +C<groups> - If set, snapshot subroups within a group, deeply (default: false) + +=item * + +C<history> - If set, snapshot historical entries within an entry (default: false) + +=back + +For example, if you begin a transaction on a group object using the C<entries> option, like this: + + $group->begin_work(entries => 1); + +Then if you modify any of the group's entries OR add new entries OR delete entries, all of that will be undone +if the transaction is rolled back. With a default-configured transaction, however, changes to entries are kept +even if the transaction is rolled back. + +=head2 commit + + $object->commit; + +Commit a transaction, making updates to C<$object> permanent. Returns itself to allow method chaining. + +=head2 rollback + + $object->rollback; + +Roll back the most recent transaction, throwing away any updates to the L</object> made since the transaction +began. Returns itself to allow method chaining. + +=for Pod::Coverage STORABLE_freeze STORABLE_thaw TO_JSON + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Safe.pm b/lib/File/KDBX/Safe.pm new file mode 100644 index 0000000..5bd55a9 --- /dev/null +++ b/lib/File/KDBX/Safe.pm @@ -0,0 +1,338 @@ +package File::KDBX::Safe; +# ABSTRACT: Keep strings encrypted while in memory + +use warnings; +use strict; + +use Crypt::PRNG qw(random_bytes); +use Devel::GlobalDestruction; +use Encode qw(encode decode); +use File::KDBX::Constants qw(:random_stream); +use File::KDBX::Error; +use File::KDBX::Util qw(erase erase_scoped); +use Ref::Util qw(is_arrayref is_coderef is_hashref is_scalarref); +use Scalar::Util qw(refaddr); +use namespace::clean; + +our $VERSION = '0.800'; # VERSION + + +sub new { + my $class = shift; + my %args = @_ % 2 == 0 ? @_ : (strings => shift, @_); + + if (!$args{cipher} && $args{key}) { + require File::KDBX::Cipher; + $args{cipher} = File::KDBX::Cipher->new(stream_id => STREAM_ID_CHACHA20, key => $args{key}); + } + + my $self = bless \%args, $class; + $self->cipher->finish; + $self->{counter} = 0; + + my $strings = delete $args{strings}; + $self->{items} = []; + $self->{index} = {}; + $self->add($strings) if $strings; + + return $self; +} + +sub DESTROY { local ($., $@, $!, $^E, $?); !in_global_destruction and $_[0]->unlock } + + +sub clear { + my $self = shift; + $self->{items} = []; + $self->{index} = {}; + $self->{counter} = 0; + return $self; +} + + +sub lock { shift->add(@_) } + +sub add { + my $self = shift; + my @strings = map { is_arrayref($_) ? @$_ : $_ } @_; + + @strings or throw 'Must provide strings to lock'; + + my $cipher = $self->cipher; + + for my $string (@strings) { + my $item = {str => $string, off => $self->{counter}}; + if (is_scalarref($string)) { + next if !defined $$string; + $item->{enc} = 'UTF-8' if utf8::is_utf8($$string); + if (my $encoding = $item->{enc}) { + my $encoded = encode($encoding, $$string); + $item->{val} = $cipher->crypt(\$encoded); + erase $encoded; + } + else { + $item->{val} = $cipher->crypt($string); + } + erase $string; + } + elsif (is_hashref($string)) { + next if !defined $string->{value}; + $item->{enc} = 'UTF-8' if utf8::is_utf8($string->{value}); + if (my $encoding = $item->{enc}) { + my $encoded = encode($encoding, $string->{value}); + $item->{val} = $cipher->crypt(\$encoded); + erase $encoded; + } + else { + $item->{val} = $cipher->crypt(\$string->{value}); + } + erase \$string->{value}; + } + else { + throw 'Safe strings must be a hashref or stringref', type => ref $string; + } + push @{$self->{items}}, $item; + $self->{index}{refaddr($string)} = $item; + $self->{counter} += length($item->{val}); + } + + return $self; +} + + +sub lock_protected { shift->add_protected(@_) } + +sub add_protected { + my $self = shift; + my $filter = is_coderef($_[0]) ? shift : undef; + my @strings = map { is_arrayref($_) ? @$_ : $_ } @_; + + @strings or throw 'Must provide strings to lock'; + + for my $string (@strings) { + my $item = {str => $string}; + $item->{filter} = $filter if defined $filter; + if (is_scalarref($string)) { + next if !defined $$string; + $item->{val} = $$string; + erase $string; + } + elsif (is_hashref($string)) { + next if !defined $string->{value}; + $item->{val} = $string->{value}; + erase \$string->{value}; + } + else { + throw 'Safe strings must be a hashref or stringref', type => ref $string; + } + push @{$self->{items}}, $item; + $self->{index}{refaddr($string)} = $item; + $self->{counter} += length($item->{val}); + } + + return $self; +} + + +sub unlock { + my $self = shift; + + my $cipher = $self->cipher; + $cipher->finish; + $self->{counter} = 0; + + for my $item (@{$self->{items}}) { + my $string = $item->{str}; + my $cleanup = erase_scoped \$item->{val}; + my $str_ref; + if (is_scalarref($string)) { + $$string = $cipher->crypt(\$item->{val}); + if (my $encoding = $item->{enc}) { + my $decoded = decode($encoding, $string->{value}); + erase $string; + $$string = $decoded; + } + $str_ref = $string; + } + elsif (is_hashref($string)) { + $string->{value} = $cipher->crypt(\$item->{val}); + if (my $encoding = $item->{enc}) { + my $decoded = decode($encoding, $string->{value}); + erase \$string->{value}; + $string->{value} = $decoded; + } + $str_ref = \$string->{value}; + } + else { + die 'Unexpected'; + } + if (my $filter = $item->{filter}) { + my $filtered = $filter->($$str_ref); + erase $str_ref; + $$str_ref = $filtered; + } + } + + return $self->clear; +} + + +sub peek { + my $self = shift; + my $string = shift; + + my $item = $self->{index}{refaddr($string)} // return; + + my $cipher = $self->cipher->dup(offset => $item->{off}); + + my $value = $cipher->crypt(\$item->{val}); + if (my $encoding = $item->{enc}) { + my $decoded = decode($encoding, $value); + erase $value; + return $decoded; + } + return $value; +} + + +sub cipher { + my $self = shift; + $self->{cipher} //= do { + require File::KDBX::Cipher; + File::KDBX::Cipher->new(stream_id => STREAM_ID_CHACHA20, key => random_bytes(64)); + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Safe - Keep strings encrypted while in memory + +=head1 VERSION + +version 0.800 + +=head1 SYNOPSIS + + use File::KDBX::Safe; + + $safe = File::KDBX::Safe->new; + + my $msg = 'Secret text'; + $safe->add(\$msg); + # $msg is now undef, the original message no longer in RAM + + my $obj = { value => 'Also secret' }; + $safe->add($obj); + # $obj is now { value => undef } + + say $safe->peek($msg); # Secret text + + $safe->unlock; + say $msg; # Secret text + say $obj->{value}; # Also secret + +=head1 DESCRIPTION + +This module provides memory protection functionality. It keeps strings encrypted in memory and decrypts them +as-needed. Encryption and decryption is done using a L<File::KDBX::Cipher::Stream>. + +A safe can protect one or more (possibly many) strings. When a string is added to a safe, it gets added to an +internal list so it will be decrypted when the entire safe is unlocked. + +=head1 ATTRIBUTES + +=head2 cipher + + $cipher = $safe->cipher; + +Get the L<File::KDBX::Cipher::Stream> protecting a safe. + +=head1 METHODS + +=head2 new + + $safe = File::KDBX::Safe->new(%attributes); + $safe = File::KDBX::Safe->new(\@strings, %attributes); + +Create a new safe for storing secret strings encrypted in memory. + +If a cipher is passed, its stream will be reset. + +=head2 clear + + $safe = $safe->clear; + +Clear a safe, removing all store contents permanently. Returns itself to allow method chaining. + +=head2 lock + +=head2 add + + $safe = $safe->lock(@strings); + $safe = $safe->lock(\@strings); + +Add one or more strings to the memory protection stream. Returns itself to allow method chaining. + +=head2 lock_protected + +=head2 add_protected + + $safe = $safe->lock_protected(@strings); + $safe = $safe->lock_protected(\@strings); + +Add strings that are already encrypted. Returns itself to allow method chaining. + +B<WARNING:> The cipher must be the same as was used to originally encrypt the strings. You must add +already-encrypted strings in the order in which they were original encrypted or they will not decrypt +correctly. You almost certainly do not want to add both unprotected and protected strings to a safe. + +=head2 unlock + + $safe = $safe->unlock; + +Decrypt all the strings. Each stored string is set to its original value, potentially overwriting any value +that might have been set after locking the string (so you probably should avoid modification to strings while +locked). The safe is implicitly cleared. Returns itself to allow method chaining. + +This happens automatically when the safe is garbage-collected. + +=head2 peek + + $string_value = $safe->peek($string); + ... + erase $string_value; + +Peek into the safe at a particular string without decrypting the whole safe. A copy of the string is returned, +and in order to ensure integrity of the memory protection you should erase the copy when you're done. + +Returns C<undef> if the given C<$string> is not in memory protection. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Transaction.pm b/lib/File/KDBX/Transaction.pm new file mode 100644 index 0000000..8cf88e6 --- /dev/null +++ b/lib/File/KDBX/Transaction.pm @@ -0,0 +1,111 @@ +package File::KDBX::Transaction; +# ABSTRACT: Make multiple database edits atomically + +use warnings; +use strict; + +use Devel::GlobalDestruction; +use File::KDBX::Util qw(:class); +use namespace::clean; + +our $VERSION = '0.800'; # VERSION + + +sub new { + my $class = shift; + my $object = shift; + $object->begin_work(@_); + return bless {object => $object}, $class; +} + +sub DESTROY { !in_global_destruction and $_[0]->rollback } + + +has 'object', is => 'ro'; + + +sub commit { + my $self = shift; + return if $self->{done}; + + my $obj = $self->object; + $obj->commit; + $self->{done} = 1; + return $obj; +} + + +sub rollback { + my $self = shift; + return if $self->{done}; + + my $obj = $self->object; + $obj->rollback; + $self->{done} = 1; + return $obj; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Transaction - Make multiple database edits atomically + +=head1 VERSION + +version 0.800 + +=head1 ATTRIBUTES + +=head2 object + +Get the object being transacted on. + +=head1 METHODS + +=head2 new + + $txn = File::KDBX::Transaction->new($object); + +Construct a new database transaction for editing an object atomically. + +=head2 commit + + $txn->commit; + +Commit the transaction, making updates to the L</object> permanent. + +=head2 rollback + + $txn->rollback; + +Roll back the transaction, throwing away any updates to the L</object> made since the transaction began. This +happens automatically when the transaction is released, unless it has already been committed. + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm new file mode 100644 index 0000000..6905691 --- /dev/null +++ b/lib/File/KDBX/Util.pm @@ -0,0 +1,1224 @@ +package File::KDBX::Util; +# ABSTRACT: Utility functions for working with KDBX files + +use warnings; +use strict; + +use Crypt::PRNG qw(random_bytes random_string); +use Encode qw(decode encode); +use Exporter qw(import); +use File::KDBX::Constants qw(:bool); +use File::KDBX::Error; +use List::Util 1.33 qw(any all); +use Module::Load; +use Ref::Util qw(is_arrayref is_coderef is_hashref is_ref is_refref is_scalarref); +use Scalar::Util qw(blessed looks_like_number readonly); +use Time::Piece; +use boolean; +use namespace::clean -except => 'import'; + +our $VERSION = '0.800'; # VERSION + +our %EXPORT_TAGS = ( + assert => [qw(DEBUG assert assert_64bit)], + class => [qw(extends has list_attributes)], + clone => [qw(clone clone_nomagic)], + coercion => [qw(to_bool to_number to_string to_time to_tristate to_uuid)], + crypt => [qw(pad_pkcs7)], + debug => [qw(DEBUG dumper)], + fork => [qw(can_fork)], + function => [qw(memoize recurse_limit)], + empty => [qw(empty nonempty)], + erase => [qw(erase erase_scoped)], + gzip => [qw(gzip gunzip)], + io => [qw(is_readable is_writable read_all)], + load => [qw(load_optional load_xs try_load_optional)], + search => [qw(query query_any search simple_expression_query)], + text => [qw(snakify trim)], + uuid => [qw(format_uuid generate_uuid is_uuid uuid UUID_NULL)], + uri => [qw(split_url uri_escape_utf8 uri_unescape_utf8)], +); + +$EXPORT_TAGS{all} = [map { @$_ } values %EXPORT_TAGS]; +our @EXPORT_OK = @{$EXPORT_TAGS{all}}; + +BEGIN { + my $debug = $ENV{DEBUG}; + $debug = looks_like_number($debug) ? (0 + $debug) : ($debug ? 1 : 0); + *DEBUG = $debug == 1 ? sub() { 1 } : + $debug == 2 ? sub() { 2 } : + $debug == 3 ? sub() { 3 } : + $debug == 4 ? sub() { 4 } : sub() { 0 }; +} + +my %OPS = ( + 'eq' => 2, # binary + 'ne' => 2, + 'lt' => 2, + 'gt' => 2, + 'le' => 2, + 'ge' => 2, + '==' => 2, + '!=' => 2, + '<' => 2, + '>' => 2, + '<=' => 2, + '>=' => 2, + '=~' => 2, + '!~' => 2, + '!' => 1, # unary + '!!' => 1, + '-not' => 1, # special + '-false' => 1, + '-true' => 1, + '-defined' => 1, + '-undef' => 1, + '-empty' => 1, + '-nonempty' => 1, + '-or' => -1, + '-and' => -1, +); +my %OP_NEG = ( + 'eq' => 'ne', + 'ne' => 'eq', + 'lt' => 'ge', + 'gt' => 'le', + 'le' => 'gt', + 'ge' => 'lt', + '==' => '!=', + '!=' => '==', + '<' => '>=', + '>' => '<=', + '<=' => '>', + '>=' => '<', + '=~' => '!~', + '!~' => '=~', +); +my %ATTRIBUTES; + + +my $XS_LOADED; +sub load_xs { + my $version = shift; + + goto IS_LOADED if defined $XS_LOADED; + + if ($ENV{PERL_ONLY} || (exists $ENV{PERL_FILE_KDBX_XS} && !$ENV{PERL_FILE_KDBX_XS})) { + return $XS_LOADED = FALSE; + } + + $XS_LOADED = !!eval { require File::KDBX::XS; 1 }; + + IS_LOADED: + { + local $@; + return $XS_LOADED if !$version; + return !!eval { File::KDBX::XS->VERSION($version); 1 }; + } +} + + +sub assert(&) { ## no critic (ProhibitSubroutinePrototypes) + return if !DEBUG; + my $code = shift; + return if $code->(); + + (undef, my $file, my $line) = caller; + $file =~ s!([^/\\]+)$!$1!; + my $assertion = ''; + if (try_load_optional('B::Deparse')) { + my $deparse = B::Deparse->new(qw{-P -x9}); + $assertion = $deparse->coderef2text($code); + $assertion =~ s/^\{(?:\s*(?:package[^;]+|use[^;]+);)*\s*(.*?);\s*\}$/$1/s; + $assertion =~ s/\s+/ /gs; + $assertion = ": $assertion"; + } + die "$0: $file:$line: Assertion failed$assertion\n"; +} + + +sub assert_64bit() { + require Config; + $Config::Config{ivsize} < 8 + and throw "64-bit perl is required to use this feature.\n", ivsize => $Config::Config{ivsize}; +} + + +sub can_fork { + require Config; + return 1 if $Config::Config{d_fork}; + return 0 if $^O ne 'MSWin32' && $^O ne 'NetWare'; + return 0 if !$Config::Config{useithreads}; + return 0 if $Config::Config{ccflags} !~ /-DPERL_IMPLICIT_SYS/; + return 0 if $] < 5.008001; + if ($] == 5.010000 && $Config::Config{ccname} eq 'gcc' && $Config::Config{gccversion}) { + return 0 if $Config::Config{gccversion} !~ m/^(\d+)\.(\d+)/; + my @parts = split(/[\.\s]+/, $Config::Config{gccversion}); + return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8); + } + return 0 if $INC{'Devel/Cover.pm'}; + return 1; +} + + +sub clone { + require Storable; + goto &Storable::dclone; +} + + +sub clone_nomagic { + my $thing = shift; + if (is_arrayref($thing)) { + my @arr = map { clone_nomagic($_) } @$thing; + return \@arr; + } + elsif (is_hashref($thing)) { + my %hash; + $hash{$_} = clone_nomagic($thing->{$_}) for keys %$thing; + return \%hash; + } + elsif (is_ref($thing)) { + return clone($thing); + } + return $thing; +} + + +sub dumper { + require Data::Dumper; + # avoid "once" warnings + local $Data::Dumper::Deepcopy = $Data::Dumper::Deepcopy = 1; + local $Data::Dumper::Deparse = $Data::Dumper::Deparse = 1; + local $Data::Dumper::Indent = 1; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Terse = 1; + local $Data::Dumper::Trailingcomma = 1; + local $Data::Dumper::Useqq = 1; + + my @dumps; + for my $struct (@_) { + my $str = Data::Dumper::Dumper($struct); + + # boolean + $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/boolean($1)/gs; + # Time::Piece + $str =~ s/bless\([^\)]+?(\d+)'?,\s+\d+,?\s+\], 'Time::Piece' \),/ + "scalar gmtime($1), # " . scalar gmtime($1)->datetime/ges; + + print STDERR $str if !defined wantarray; + push @dumps, $str; + return $str; + } + return join("\n", @dumps); +} + + +sub empty { _empty(@_) } +sub nonempty { !_empty(@_) } + +sub _empty { + return 1 if @_ == 0; + local $_ = shift; + return !defined $_ + || $_ eq '' + || (is_arrayref($_) && @$_ == 0) + || (is_hashref($_) && keys %$_ == 0) + || (is_scalarref($_) && (!defined $$_ || $$_ eq '')) + || (is_refref($_) && _empty($$_)); +} + + +BEGIN { + if (load_xs) { + *_CowREFCNT = \&File::KDBX::XS::CowREFCNT; + } + elsif (eval { require B::COW; 1 }) { + *_CowREFCNT = \&B::COW::cowrefcnt; + } + else { + *_CowREFCNT = sub { undef }; + } +} + +sub erase { + # Only bother zeroing out memory if we have the last SvPV COW reference, otherwise we'll end up just + # creating a copy and erasing the copy. + # TODO - Is this worth doing? Need some benchmarking. + for (@_) { + if (!is_ref($_)) { + next if !defined $_ || readonly $_; + my $cowrefcnt = _CowREFCNT($_); + goto FREE_NONREF if defined $cowrefcnt && 1 < $cowrefcnt; + # if (__PACKAGE__->can('erase_xs')) { + # erase_xs($_); + # } + # else { + substr($_, 0, length($_), "\0" x length($_)); + # } + FREE_NONREF: { + no warnings 'uninitialized'; + undef $_; + } + } + elsif (is_scalarref($_)) { + next if !defined $$_ || readonly $$_; + my $cowrefcnt = _CowREFCNT($$_); + goto FREE_REF if defined $cowrefcnt && 1 < $cowrefcnt; + # if (__PACKAGE__->can('erase_xs')) { + # erase_xs($$_); + # } + # else { + substr($$_, 0, length($$_), "\0" x length($$_)); + # } + FREE_REF: { + no warnings 'uninitialized'; + undef $$_; + } + } + elsif (is_arrayref($_)) { + erase(@$_); + @$_ = (); + } + elsif (is_hashref($_)) { + erase(values %$_); + %$_ = (); + } + else { + throw 'Cannot erase this type of scalar', type => ref $_, what => $_; + } + } +} + + +sub erase_scoped { + throw 'Programmer error: Cannot call erase_scoped in void context' if !defined wantarray; + my @args; + for (@_) { + !is_ref($_) || is_arrayref($_) || is_hashref($_) || is_scalarref($_) + or throw 'Cannot erase this type of scalar', type => ref $_, what => $_; + push @args, is_ref($_) ? $_ : \$_; + } + require Scope::Guard; + return Scope::Guard->new(sub { erase(@args) }); +} + + +sub extends { + my $parent = shift; + my $caller = caller; + load $parent; + no strict 'refs'; ## no critic (ProhibitNoStrict) + @{"${caller}::ISA"} = $parent; +} + + +sub has { + my $name = shift; + my %args = @_ % 2 == 1 ? (default => shift, @_) : @_; + + my ($package, $file, $line) = caller; + + my $d = $args{default}; + my $default = is_arrayref($d) ? sub { [@$d] } : is_hashref($d) ? sub { +{%$d} } : $d; + my $coerce = $args{coerce}; + my $is = $args{is} || 'rw'; + + my $store = $args{store}; + ($store, $name) = split(/\./, $name, 2) if $name =~ /\./; + + my @path = split(/\./, $args{path} || ''); + my $last = pop @path; + my $path = $last ? join('', map { qq{->$_} } @path) . qq{->{'$last'}} + : $store ? qq{->$store\->{'$name'}} : qq{->{'$name'}}; + my $member = qq{\$_[0]$path}; + + + my $default_code = is_coderef $default ? q{scalar $default->($_[0])} + : defined $default ? q{$default} + : q{undef}; + my $get = qq{$member //= $default_code;}; + + my $set = ''; + if ($is eq 'rw') { + $set = is_coderef $coerce ? qq{$member = scalar \$coerce->(\@_[1..\$#_]) if \$#_;} + : defined $coerce ? qq{$member = do { local @_ = (\@_[1..\$#_]); $coerce } if \$#_;} + : qq{$member = \$_[1] if \$#_;}; + } + + push @{$ATTRIBUTES{$package} //= []}, $name; + $line -= 4; + my $code = <<END; +# line $line "$file" +sub ${package}::${name} { + return $default_code if !Scalar::Util::blessed(\$_[0]); + $set + $get +} +END + eval $code; ## no critic (ProhibitStringyEval) +} + + +sub format_uuid { + local $_ = shift // "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"; + my $delim = shift // ''; + length($_) == 16 or throw 'Must provide a 16-bytes UUID', size => length($_), str => $_; + return uc(join($delim, unpack('H8 H4 H4 H4 H12', $_))); +} + + +sub generate_uuid { + my $set = @_ % 2 == 1 ? shift : undef; + my %args = @_; + my $test = $set //= $args{test}; + $test = sub { !$set->{$_} } if is_hashref($test); + $test //= sub { 1 }; + my $printable = $args{printable} // $args{print}; + local $_ = ''; + do { + $_ = $printable ? random_string(16) : random_bytes(16); + } while (!$test->($_)); + return $_; +} + + +sub gunzip { + load_optional('Compress::Raw::Zlib'); + local $_ = shift; + my ($i, $status) = Compress::Raw::Zlib::Inflate->new(-WindowBits => 31); + $status == Compress::Raw::Zlib::Z_OK() + or throw 'Failed to initialize compression library', status => $status; + $status = $i->inflate($_, my $out); + $status == Compress::Raw::Zlib::Z_STREAM_END() + or throw 'Failed to decompress data', status => $status; + return $out; +} + + +sub gzip { + load_optional('Compress::Raw::Zlib'); + local $_ = shift; + my ($d, $status) = Compress::Raw::Zlib::Deflate->new(-WindowBits => 31, -AppendOutput => 1); + $status == Compress::Raw::Zlib::Z_OK() + or throw 'Failed to initialize compression library', status => $status; + $status = $d->deflate($_, my $out); + $status == Compress::Raw::Zlib::Z_OK() + or throw 'Failed to compress data', status => $status; + $status = $d->flush($out); + $status == Compress::Raw::Zlib::Z_OK() + or throw 'Failed to compress data', status => $status; + return $out; +} + + +sub is_readable { $_[0] !~ /^[aw]b?$/ } +sub is_writable { $_[0] !~ /^rb?$/ } + + +sub is_uuid { defined $_[0] && !is_ref($_[0]) && length($_[0]) == 16 } + + +sub list_attributes { + my $package = shift; + return @{$ATTRIBUTES{$package} // []}; +} + + +sub load_optional { + for my $module (@_) { + eval { load $module }; + if (my $err = $@) { + throw "Missing dependency: Please install $module to use this feature.\n", + module => $module, + error => $err; + } + } + return wantarray ? @_ : $_[0]; +} + + +sub memoize { + my $func = shift; + my @args = @_; + my %cache; + return sub { $cache{join("\0", grep { defined } @_)} //= $func->(@args, @_) }; +} + + +sub pad_pkcs7 { + my $data = shift // throw 'Must provide a string to pad'; + my $size = shift or throw 'Must provide block size'; + + 0 <= $size && $size < 256 + or throw 'Cannot add PKCS7 padding to a large block size', size => $size; + + my $pad_len = $size - length($data) % $size; + $data .= chr($pad_len) x $pad_len; +} + + +sub query { _query(undef, '-or', \@_) } + + +sub query_any { + my $code = shift; + + if (is_coderef($code) || overload::Method($code, '&{}')) { + return $code; + } + elsif (is_scalarref($code)) { + return simple_expression_query($$code, @_); + } + else { + return query($code, @_); + } +} + + +sub read_all($$$;$) { ## no critic (ProhibitSubroutinePrototypes) + my $result = @_ == 3 ? read($_[0], $_[1], $_[2]) + : read($_[0], $_[1], $_[2], $_[3]); + return if !defined $result; + return if $result != $_[2]; + return $result; +} + + +sub recurse_limit { + my $func = shift; + my $max_depth = shift // 200; + my $error = shift // sub {}; + my $depth = 0; + return sub { return $error->(@_) if $max_depth < ++$depth; $func->(@_) }; +}; + + +sub search { + my $list = shift; + my $query = query_any(@_); + + my @match; + for my $item (@$list) { + push @match, $item if $query->($item); + } + return \@match; +} + + +sub simple_expression_query { + my $expr = shift; + my $op = @_ && ($OPS{$_[0] || ''} || 0) == 2 ? shift : '=~'; + + my $neg_op = $OP_NEG{$op}; + my $is_re = $op eq '=~' || $op eq '!~'; + + require Text::ParseWords; + my @terms = Text::ParseWords::shellwords($expr); + + my @query = qw(-and); + + for my $term (@terms) { + my @subquery = qw(-or); + + my $neg = $term =~ s/^-//; + my $condition = [($neg ? $neg_op : $op) => ($is_re ? qr/\Q$term\E/i : $term)]; + + for my $field (@_) { + push @subquery, $field => $condition; + } + + push @query, \@subquery; + } + + return query(\@query); +} + + +sub snakify { + local $_ = shift; + s/UserName/Username/g; + s/([a-z])([A-Z0-9])/${1}_${2}/g; + s/([A-Z0-9]+)([A-Z0-9])(?![A-Z0-9]|$)/${1}_${2}/g; + return lc($_); +} + + +sub split_url { + local $_ = shift; + my ($scheme, $auth, $host, $port, $path, $query, $hash) =~ m! + ^([^:/\?\#]+) :// + (?:([^\@]+)\@) + ([^:/\?\#]*) + (?::(\d+))? + ([^\?\#]*) + (\?[^\#]*)? + (\#(.*))? + !x; + + $scheme = lc($scheme); + + $host ||= 'localhost'; + $host = lc($host); + + $path = "/$path" if $path !~ m!^/!; + + $port ||= $scheme eq 'http' ? 80 : $scheme eq 'https' ? 433 : undef; + + my ($username, $password) = split($auth, ':', 2); + + return ($scheme, $auth, $host, $port, $path, $query, $hash, $username, $password); +} + + +sub to_bool { $_[0] // return; boolean($_[0]) } +sub to_number { $_[0] // return; 0+$_[0] } +sub to_string { $_[0] // return; "$_[0]" } +sub to_time { + $_[0] // return; + return scalar gmtime($_[0]) if looks_like_number($_[0]); + return scalar gmtime if $_[0] eq 'now'; + return Time::Piece->strptime($_[0], '%Y-%m-%d %H:%M:%S') if !blessed $_[0]; + return $_[0]; +} +sub to_tristate { $_[0] // return; boolean($_[0]) } +sub to_uuid { + my $str = to_string(@_) // return; + return sprintf('%016s', $str) if length($str) < 16; + return substr($str, 0, 16) if 16 < length($str); + return $str; +} + + +sub trim($) { ## no critic (ProhibitSubroutinePrototypes) + local $_ = shift // return; + s/^\s*//; + s/\s*$//; + return $_; +} + + +sub try_load_optional { + for my $module (@_) { + eval { load $module }; + if (my $err = $@) { + warn $err if 3 <= DEBUG; + return; + } + } + return @_; +} + + +my %ESC = map { chr($_) => sprintf('%%%02X', $_) } 0..255; +sub uri_escape_utf8 { + local $_ = shift // return; + $_ = encode('UTF-8', $_); + # RFC 3986 section 2.3 unreserved characters + s/([^A-Za-z0-9\-\._~])/$ESC{$1}/ge; + return $_; +} + + +sub uri_unescape_utf8 { + local $_ = shift // return; + s/\%([A-Fa-f0-9]{2})/chr(hex($1))/; + return decode('UTF-8', $_); +} + + +sub uuid { + local $_ = shift // return "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"; + s/-//g; + /^[A-Fa-f0-9]{32}$/ or throw 'Must provide a formatted 128-bit UUID'; + return pack('H32', $_); + +} + + +sub UUID_NULL() { "\0" x 16 } + +### -------------------------------------------------------------------------- + +# Determine if an array looks like keypairs from a hash. +sub _looks_like_keypairs { + my $arr = shift; + return 0 if @$arr % 2 == 1; + for (my $i = 0; $i < @$arr; $i += 2) { + return 0 if is_ref($arr->[$i]); + } + return 1; +} + +sub _is_operand_plain { + local $_ = shift; + return !(is_hashref($_) || is_arrayref($_)); +} + +sub _query { + # dumper \@_; + my $subject = shift; + my $op = shift // throw 'Must specify a query operator'; + my $operand = shift; + + return _query_simple($op, $subject) if defined $subject && !is_ref($op) && ($OPS{$subject} || 2) < 2; + return _query_simple($subject, $op, $operand) if _is_operand_plain($operand); + return _query_inverse(_query($subject, '-or', $operand)) if $op eq '-not' || $op eq '-false'; + return _query($subject, '-and', [%$operand]) if is_hashref($operand); + + my @queries; + + my @atoms = @$operand; + while (@atoms) { + if (_looks_like_keypairs(\@atoms)) { + my ($atom, $operand) = splice @atoms, 0, 2; + if (my $op_type = $OPS{$atom}) { + if ($op_type == 1 && _is_operand_plain($operand)) { # unary + push @queries, _query_simple($operand, $atom); + } + else { + push @queries, _query($subject, $atom, $operand); + } + } + elsif (!is_ref($atom)) { + push @queries, _query($atom, 'eq', $operand); + } + } + else { + my $atom = shift @atoms; + if ($OPS{$atom}) { # apply new operator over the rest + push @queries, _query($subject, $atom, \@atoms); + last; + } + else { # apply original operator over this one + push @queries, _query($subject, $op, $atom); + } + } + } + + if (@queries == 1) { + return $queries[0]; + } + elsif ($op eq '-and') { + return _query_all(@queries); + } + elsif ($op eq '-or') { + return _query_any(@queries); + } + throw 'Malformed query'; +} + +sub _query_simple { + my $subject = shift; + my $op = shift // 'eq'; + my $operand = shift; + + # these special operators can also act as simple operators + $op = '!!' if $op eq '-true'; + $op = '!' if $op eq '-false'; + $op = '!' if $op eq '-not'; + + defined $subject or throw 'Subject is not set in query'; + $OPS{$op} >= 0 or throw 'Cannot use a non-simple operator in a simple query'; + if (empty($operand)) { + if ($OPS{$op} < 2) { + # no operand needed + } + # Allow field => undef and field => {'ne' => undef} to do the (arguably) right thing. + elsif ($op eq 'eq' || $op eq '==') { + $op = '-empty'; + } + elsif ($op eq 'ne' || $op eq '!=') { + $op = '-nonempty'; + } + else { + throw 'Operand is required'; + } + } + + my $field = sub { blessed $_[0] && $_[0]->can($subject) ? $_[0]->$subject : $_[0]->{$subject} }; + + my %map = ( + 'eq' => sub { local $_ = $field->(@_); defined && $_ eq $operand }, + 'ne' => sub { local $_ = $field->(@_); defined && $_ ne $operand }, + 'lt' => sub { local $_ = $field->(@_); defined && $_ lt $operand }, + 'gt' => sub { local $_ = $field->(@_); defined && $_ gt $operand }, + 'le' => sub { local $_ = $field->(@_); defined && $_ le $operand }, + 'ge' => sub { local $_ = $field->(@_); defined && $_ ge $operand }, + '==' => sub { local $_ = $field->(@_); defined && $_ == $operand }, + '!=' => sub { local $_ = $field->(@_); defined && $_ != $operand }, + '<' => sub { local $_ = $field->(@_); defined && $_ < $operand }, + '>' => sub { local $_ = $field->(@_); defined && $_ > $operand }, + '<=' => sub { local $_ = $field->(@_); defined && $_ <= $operand }, + '>=' => sub { local $_ = $field->(@_); defined && $_ >= $operand }, + '=~' => sub { local $_ = $field->(@_); defined && $_ =~ $operand }, + '!~' => sub { local $_ = $field->(@_); defined && $_ !~ $operand }, + '!' => sub { local $_ = $field->(@_); ! $_ }, + '!!' => sub { local $_ = $field->(@_); !!$_ }, + '-defined' => sub { local $_ = $field->(@_); defined $_ }, + '-undef' => sub { local $_ = $field->(@_); !defined $_ }, + '-nonempty' => sub { local $_ = $field->(@_); nonempty $_ }, + '-empty' => sub { local $_ = $field->(@_); empty $_ }, + ); + + return $map{$op} // throw "Unexpected operator in query: $op", + subject => $subject, + operator => $op, + operand => $operand; +} + +sub _query_inverse { + my $query = shift; + return sub { !$query->(@_) }; +} + +sub _query_all { + my @queries = @_; + return sub { + my $val = shift; + all { $_->($val) } @queries; + }; +} + +sub _query_any { + my @queries = @_; + return sub { + my $val = shift; + any { $_->($val) } @queries; + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +File::KDBX::Util - Utility functions for working with KDBX files + +=head1 VERSION + +version 0.800 + +=head1 FUNCTIONS + +=head2 load_xs + + $bool = load_xs(); + $bool = load_xs($version); + +Attempt to load L<File::KDBX::XS>. Return truthy if C<XS> is loaded. If C<$version> is given, it will check +that at least the given version is loaded. + +=head2 assert + + assert { ... }; + +Write an executable comment. Only executed if C<DEBUG> is set in the environment. + +=head2 assert_64bit + + assert_64bit(); + +Throw if perl doesn't support 64-bit IVs. + +=head2 can_fork + + $bool = can_fork; + +Determine if perl can fork, with logic lifted from L<Test2::Util/CAN_FORK>. + +=head2 clone + + $clone = clone($thing); + +Clone deeply. This is an unadorned alias to L<Storable> C<dclone>. + +=head2 clone_nomagic + + $clone = clone_nomagic($thing); + +Clone deeply without keeping [most of] the magic. + +B<WARNING:> At the moment the implementation is naïve and won't respond well to nontrivial data or recursive +structures. + +=head2 DEBUG + +Constant number indicating the level of debuggingness. + +=head2 dumper + + $str = dumper $thing; + dumper $thing; # in void context, prints to STDERR + +Like L<Data::Dumper> but slightly terser in some cases relevent to L<File::KDBX>. + +=head2 empty + +=head2 nonempty + + $bool = empty $thing; + + $bool = nonempty $thing; + +Test whether a thing is empty (or nonempty). An empty thing is one of these: + +=over 4 + +=item * + +nonexistent + +=item * + +C<undef> + +=item * + +zero-length string + +=item * + +zero-length array + +=item * + +hash with zero keys + +=item * + +reference to an empty thing (recursive) + +=back + +Note in particular that zero C<0> is not considered empty because it is an actual value. + +=head2 erase + + erase($string, ...); + erase(\$string, ...); + +Overwrite the memory used by one or more string. + +=head2 erase_scoped + + $scope_guard = erase_scoped($string, ...); + $scope_guard = erase_scoped(\$string, ...); + undef $scope_guard; # erase happens here + +Get a scope guard that will cause scalars to be erased later (i.e. when the scope ends). This is useful if you +want to make sure a string gets erased after you're done with it, even if the scope ends abnormally. + +See L</erase>. + +=head2 extends + + extends $class; + +Set up the current module to inheret from another module. + +=head2 has + + has $name => %options; + +Create an attribute getter/setter. Possible options: + +=over 4 + +=item * + +C<is> - Either "rw" (default) or "ro" + +=item * + +C<default> - Default value + +=item * + +C<coerce> - Coercive function + +=back + +=head2 format_uuid + + $string_uuid = format_uuid($raw_uuid); + $string_uuid = format_uuid($raw_uuid, $delimiter); + +Format a 128-bit UUID (given as a string of 16 octets) into a hexidecimal string, optionally with a delimiter +to break up the UUID visually into five parts. Examples: + + my $uuid = uuid('01234567-89AB-CDEF-0123-456789ABCDEF'); + say format_uuid($uuid); # -> 0123456789ABCDEF0123456789ABCDEF + say format_uuid($uuid, '-'); # -> 01234567-89AB-CDEF-0123-456789ABCDEF + +This is the inverse of L</uuid>. + +=head2 generate_uuid + + $uuid = generate_uuid; + $uuid = generate_uuid(\%set); + $uuid = generate_uuid(\&test_uuid); + +Generate a new random UUID. It's pretty unlikely that this will generate a repeat, but if you're worried about +that you can provide either a set of existing UUIDs (as a hashref where the keys are the elements of a set) or +a function to check for existing UUIDs, and this will be sure to not return a UUID already in provided set. +Perhaps an example will make it clear: + + my %uuid_set = ( + uuid('12345678-9ABC-DEFG-1234-56789ABCDEFG') => 'whatever', + ); + $uuid = generate_uuid(\%uuid_set); + # OR + $uuid = generate_uuid(sub { !$uuid_set{$_} }); + +Here, C<$uuid> can't be "12345678-9ABC-DEFG-1234-56789ABCDEFG". This example uses L</uuid> to easily pack +a 16-byte UUID from a literal, but it otherwise is not a consequential part of the example. + +=head2 gunzip + + $unzipped = gunzip($string); + +Decompress an octet stream. + +=head2 gzip + + $zipped = gzip($string); + +Compress an octet stream. + +=head2 is_readable + +=head2 is_writable + + $bool = is_readable($mode); + $bool = is_writable($mode); + +Determine of an C<fopen>-style mode is readable, writable or both. + +=head2 is_uuid + + $bool = is_uuid($thing); + +Check if a thing is a UUID (i.e. scalar string of length 16). + +=head2 list_attributes + + @attributes = list_attributes($package); + +Get a list of attributes for a class. + +=head2 load_optional + + $package = load_optional($package); + +Load a module that isn't required but can provide extra functionality. Throw if the module is not available. + +=head2 memoize + + \&memoized_code = memoize(\&code, ...); + +Memoize a function. Extra arguments are passed through to C<&code> when it is called. + +=head2 pad_pkcs7 + + $padded_string = pad_pkcs7($string, $block_size), + +Pad a block using the PKCS#7 method. + +=head2 query + + $query = query(@where); + $query->(\%data); + +Generate a function that will run a series of tests on a passed hashref and return true or false depending on +if the data record in the hash matched the specified logic. + +The logic can be specified in a manner similar to L<SQL::Abstract/"WHERE CLAUSES"> which was the inspiration +for this function, but this code is distinct, supporting an overlapping but not identical feature set and +having its own bugs. + +See L<File::KDBX/QUERY> for examples. + +=head2 query_any + +Get either a L</query> or L</simple_expression_query>, depending on the arguments. + +=head2 read_all + + $size = read_all($fh, my $buffer, $size); + $size = read_all($fh, my $buffer, $size, $offset); + +Like L<functions/read> but returns C<undef> if not all C<$size> bytes are read. This is considered an error, +distinguishable from other errors by C<$!> not being set. + +=head2 recurse_limit + + \&limited_code = recurse_limit(\&code); + \&limited_code = recurse_limit(\&code, $max_depth); + \&limited_code = recurse_limit(\&code, $max_depth, \&error_handler); + +Wrap a function with a guard to prevent deep recursion. + +=head2 search + + # Generate a query on-the-fly: + \@matches = search(\@records, @where); + + # Use a pre-compiled query: + $query = query(@where); + \@matches = search(\@records, $query); + + # Use a simple expression: + \@matches = search(\@records, \'query terms', @fields); + \@matches = search(\@records, \'query terms', $operator, @fields); + + # Use your own subroutine: + \@matches = search(\@records, \&query); + \@matches = search(\@records, sub { $record = shift; ... }); + +Execute a linear search over an array of records using a L</query>. A "record" is usually a hash. + +=head2 simple_expression_query + + $query = simple_expression_query($expression, @fields); + $query = simple_expression_query($expression, $operator, @fields); + +Generate a query, like L</query>, to be used with L</search> but built from a "simple expression" as +L<described here|https://keepass.info/help/base/search.html#mode_se>. + +An expression is a string with one or more space-separated terms. Terms with spaces can be enclosed in double +quotes. Terms are negated if they are prefixed with a minus sign. A record must match every term on at least +one of the given fields. + +=head2 snakify + + $string = snakify($string); + +Turn a CamelCase string into snake_case. + +=head2 split_url + + ($scheme, $auth, $host, $port, $path, $query, $hash, $usename, $password) = split_url($url); + +Split a URL into its parts. + +For example, C<http://user:pass@localhost:4000/path?query#hash> gets split like: + +=over 4 + +=item * + +C<http> + +=item * + +C<user:pass> + +=item * + +C<host> + +=item * + +C<4000> + +=item * + +C</path> + +=item * + +C<?query> + +=item * + +C<#hash> + +=item * + +C<user> + +=item * + +C<pass> + +=back + +=head2 to_bool + +=head2 to_number + +=head2 to_string + +=head2 to_time + +=head2 to_tristate + +=head2 to_uuid + +Various typecasting / coercive functions. + +=head2 trim + + $string = trim($string); + +The ubiquitous C<trim> function. Removes all whitespace from both ends of a string. + +=head2 try_load_optional + + $package = try_load_optional($package); + +Try to load a module that isn't required but can provide extra functionality, and return true if successful. + +=head2 uri_escape_utf8 + + $string = uri_escape_utf8($string); + +Percent-encode arbitrary text strings, like for a URI. + +=head2 uri_unescape_utf8 + + $string = uri_unescape_utf8($string); + +Inverse of L</uri_escape_utf8>. + +=head2 uuid + + $raw_uuid = uuid($string_uuid); + +Pack a 128-bit UUID (given as a hexidecimal string with optional C<->'s, like +C<12345678-9ABC-DEFG-1234-56789ABCDEFG>) into a string of exactly 16 octets. + +This is the inverse of L</format_uuid>. + +=head2 UUID_NULL + +Get the null UUID (i.e. string of 16 null bytes). + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +L<https://github.com/chazmcgarvey/File-KDBX/issues> + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Charles McGarvey <ccm@cpan.org> + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2022 by Charles McGarvey. + +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 diff --git a/perlcritic.rc b/perlcritic.rc new file mode 100644 index 0000000..29f0c88 --- /dev/null +++ b/perlcritic.rc @@ -0,0 +1,4 @@ +# We don't really do much using the return value for error-checking. I think +# in this codebase bugs would more likely be in the form if unintentionally +# returning empty list in list context. +[-Subroutines::ProhibitExplicitReturnUndef] diff --git a/t/00-compile.t b/t/00-compile.t new file mode 100644 index 0000000..1fcd9cd --- /dev/null +++ b/t/00-compile.t @@ -0,0 +1,97 @@ +use 5.006; +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::Compile 2.058 + +use Test::More; + +plan tests => 38 + ($ENV{AUTHOR_TESTING} ? 1 : 0); + +my @module_files = ( + 'File/KDBX.pm', + 'File/KDBX/Cipher.pm', + 'File/KDBX/Cipher/CBC.pm', + 'File/KDBX/Cipher/Stream.pm', + 'File/KDBX/Constants.pm', + 'File/KDBX/Dumper.pm', + 'File/KDBX/Dumper/KDB.pm', + 'File/KDBX/Dumper/Raw.pm', + 'File/KDBX/Dumper/V3.pm', + 'File/KDBX/Dumper/V4.pm', + 'File/KDBX/Dumper/XML.pm', + 'File/KDBX/Entry.pm', + 'File/KDBX/Error.pm', + 'File/KDBX/Group.pm', + 'File/KDBX/IO.pm', + 'File/KDBX/IO/Crypt.pm', + 'File/KDBX/IO/HashBlock.pm', + 'File/KDBX/IO/HmacBlock.pm', + 'File/KDBX/Iterator.pm', + 'File/KDBX/KDF.pm', + 'File/KDBX/KDF/AES.pm', + 'File/KDBX/KDF/Argon2.pm', + 'File/KDBX/Key.pm', + 'File/KDBX/Key/ChallengeResponse.pm', + 'File/KDBX/Key/Composite.pm', + 'File/KDBX/Key/File.pm', + 'File/KDBX/Key/Password.pm', + 'File/KDBX/Key/YubiKey.pm', + 'File/KDBX/Loader.pm', + 'File/KDBX/Loader/KDB.pm', + 'File/KDBX/Loader/Raw.pm', + 'File/KDBX/Loader/V3.pm', + 'File/KDBX/Loader/V4.pm', + 'File/KDBX/Loader/XML.pm', + 'File/KDBX/Object.pm', + 'File/KDBX/Safe.pm', + 'File/KDBX/Transaction.pm', + 'File/KDBX/Util.pm' +); + + + +# no fake home requested + +my @switches = ( + -d 'blib' ? '-Mblib' : '-Ilib', +); + +use File::Spec; +use IPC::Open3; +use IO::Handle; + +open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; + +my @warnings; +for my $lib (@module_files) +{ + # see L<perlfaq8/How can I capture STDERR from an external command?> + my $stderr = IO::Handle->new; + + diag('Running: ', join(', ', map { my $str = $_; $str =~ s/'/\\'/g; q{'} . $str . q{'} } + $^X, @switches, '-e', "require q[$lib]")) + if $ENV{PERL_COMPILE_TEST_DEBUG}; + + my $pid = open3($stdin, '>&STDERR', $stderr, $^X, @switches, '-e', "require q[$lib]"); + binmode $stderr, ':crlf' if $^O eq 'MSWin32'; + my @_warnings = <$stderr>; + waitpid($pid, 0); + is($?, 0, "$lib loaded ok"); + + shift @_warnings if @_warnings and $_warnings[0] =~ /^Using .*\bblib/ + and not eval { +require blib; blib->VERSION('1.01') }; + + if (@_warnings) + { + warn @_warnings; + push @warnings, @_warnings; + } +} + + + +is(scalar(@warnings), 0, 'no warnings found') + or diag 'got warnings: ', ( Test::More->can('explain') ? Test::More::explain(\@warnings) : join("\n", '', @warnings) ) if $ENV{AUTHOR_TESTING}; + + diff --git a/t/00-report-prereqs.dd b/t/00-report-prereqs.dd new file mode 100644 index 0000000..b8f2057 --- /dev/null +++ b/t/00-report-prereqs.dd @@ -0,0 +1,110 @@ +do { my $x = { + 'configure' => { + 'requires' => { + 'ExtUtils::MakeMaker' => '0' + } + }, + 'develop' => { + 'requires' => { + 'Compress::Raw::Zlib' => '0', + 'Dist::Zilla' => '5', + 'Dist::Zilla::Plugin::Encoding' => '0', + 'Dist::Zilla::Plugin::OptionalFeature' => '0', + 'Dist::Zilla::Plugin::Prereqs' => '0', + 'Dist::Zilla::Plugin::Prereqs::Soften' => '0', + 'Dist::Zilla::PluginBundle::Author::CCM' => '0', + 'File::KDBX::XS' => '0', + 'IO::Compress::Gzip' => '0', + 'IO::Uncompress::Gunzip' => '0', + 'Pass::OTP' => '0', + 'Pod::Coverage::TrustPod' => '0', + 'Software::License::Perl_5' => '0', + 'Test::CPAN::Changes' => '0.19', + 'Test::CPAN::Meta' => '0', + 'Test::CleanNamespaces' => '0.15', + 'Test::EOL' => '0', + 'Test::MinimumVersion' => '0', + 'Test::More' => '0.96', + 'Test::NoTabs' => '0', + 'Test::Perl::Critic' => '0', + 'Test::Pod' => '1.41', + 'Test::Pod::Coverage' => '1.08', + 'Test::Pod::No404s' => '0', + 'Test::Portability::Files' => '0' + } + }, + 'runtime' => { + 'recommends' => { + 'Compress::Raw::Zlib' => '0', + 'File::KDBX::XS' => '0', + 'File::Spec' => '0', + 'IO::Compress::Gzip' => '0', + 'IO::Uncompress::Gunzip' => '0', + 'Pass::OTP' => '0' + }, + 'requires' => { + 'Carp' => '0', + 'Crypt::Argon2' => '0', + 'Crypt::Cipher' => '0', + 'Crypt::Digest' => '0', + 'Crypt::Mac::HMAC' => '0', + 'Crypt::Misc' => '0.029', + 'Crypt::Mode::CBC' => '0', + 'Crypt::PRNG' => '0', + 'Data::Dumper' => '0', + 'Devel::GlobalDestruction' => '0', + 'Encode' => '0', + 'Exporter' => '0', + 'File::Temp' => '0', + 'Hash::Util::FieldHash' => '0', + 'IO::Handle' => '0', + 'IPC::Cmd' => '0.52', + 'Iterator::Simple' => '0', + 'Iterator::Simple::Iterator' => '0', + 'List::Util' => '1.33', + 'Module::Load' => '0', + 'Module::Loaded' => '0', + 'POSIX' => '0', + 'Ref::Util' => '0', + 'Scalar::Util' => '0', + 'Scope::Guard' => '0', + 'Storable' => '0', + 'Symbol' => '0', + 'Text::ParseWords' => '0', + 'Time::Piece' => '0', + 'XML::LibXML' => '0', + 'XML::LibXML::Reader' => '0', + 'boolean' => '0', + 'namespace::clean' => '0', + 'overload' => '0', + 'strict' => '0', + 'warnings' => '0' + } + }, + 'test' => { + 'recommends' => { + 'CPAN::Meta' => '2.120900', + 'Pass::OTP' => '0' + }, + 'requires' => { + 'ExtUtils::MakeMaker' => '0', + 'File::Spec' => '0', + 'FindBin' => '0', + 'Getopt::Std' => '0', + 'IO::Handle' => '0', + 'IPC::Open3' => '0', + 'Test::Deep' => '0', + 'Test::Fatal' => '0', + 'Test::More' => '0', + 'Test::Warnings' => '0', + 'lib' => '0', + 'perl' => '5.006', + 'utf8' => '0' + }, + 'suggests' => { + 'POSIX::1003' => '0' + } + } + }; + $x; + } \ No newline at end of file diff --git a/t/00-report-prereqs.t b/t/00-report-prereqs.t new file mode 100644 index 0000000..c3a94ca --- /dev/null +++ b/t/00-report-prereqs.t @@ -0,0 +1,193 @@ +#!perl + +use strict; +use warnings; + +# This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.028 + +use Test::More tests => 1; + +use ExtUtils::MakeMaker; +use File::Spec; + +# from $version::LAX +my $lax_version_re = + qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? + | + (?:\.[0-9]+) (?:_[0-9]+)? + ) | (?: + v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? + | + (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? + ) + )/x; + +# hide optional CPAN::Meta modules from prereq scanner +# and check if they are available +my $cpan_meta = "CPAN::Meta"; +my $cpan_meta_pre = "CPAN::Meta::Prereqs"; +my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic + +# Verify requirements? +my $DO_VERIFY_PREREQS = 1; + +sub _max { + my $max = shift; + $max = ( $_ > $max ) ? $_ : $max for @_; + return $max; +} + +sub _merge_prereqs { + my ($collector, $prereqs) = @_; + + # CPAN::Meta::Prereqs object + if (ref $collector eq $cpan_meta_pre) { + return $collector->with_merged_prereqs( + CPAN::Meta::Prereqs->new( $prereqs ) + ); + } + + # Raw hashrefs + for my $phase ( keys %$prereqs ) { + for my $type ( keys %{ $prereqs->{$phase} } ) { + for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { + $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; + } + } + } + + return $collector; +} + +my @include = qw( + +); + +my @exclude = qw( + +); + +# Add static prereqs to the included modules list +my $static_prereqs = do './t/00-report-prereqs.dd'; + +# Merge all prereqs (either with ::Prereqs or a hashref) +my $full_prereqs = _merge_prereqs( + ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), + $static_prereqs +); + +# Add dynamic prereqs to the included modules list (if we can) +my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; +my $cpan_meta_error; +if ( $source && $HAS_CPAN_META + && (my $meta = eval { CPAN::Meta->load_file($source) } ) +) { + $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); +} +else { + $cpan_meta_error = $@; # capture error from CPAN::Meta->load_file($source) + $source = 'static metadata'; +} + +my @full_reports; +my @dep_errors; +my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; + +# Add static includes into a fake section +for my $mod (@include) { + $req_hash->{other}{modules}{$mod} = 0; +} + +for my $phase ( qw(configure build test runtime develop other) ) { + next unless $req_hash->{$phase}; + next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); + + for my $type ( qw(requires recommends suggests conflicts modules) ) { + next unless $req_hash->{$phase}{$type}; + + my $title = ucfirst($phase).' '.ucfirst($type); + my @reports = [qw/Module Want Have/]; + + for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { + next if $mod eq 'perl'; + next if grep { $_ eq $mod } @exclude; + + my $file = $mod; + $file =~ s{::}{/}g; + $file .= ".pm"; + my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; + + my $want = $req_hash->{$phase}{$type}{$mod}; + $want = "undef" unless defined $want; + $want = "any" if !$want && $want == 0; + + my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; + + if ($prefix) { + my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); + $have = "undef" unless defined $have; + push @reports, [$mod, $want, $have]; + + if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { + if ( $have !~ /\A$lax_version_re\z/ ) { + push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; + } + elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { + push @dep_errors, "$mod version '$have' is not in required range '$want'"; + } + } + } + else { + push @reports, [$mod, $want, "missing"]; + + if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { + push @dep_errors, "$mod is not installed ($req_string)"; + } + } + } + + if ( @reports ) { + push @full_reports, "=== $title ===\n\n"; + + my $ml = _max( map { length $_->[0] } @reports ); + my $wl = _max( map { length $_->[1] } @reports ); + my $hl = _max( map { length $_->[2] } @reports ); + + if ($type eq 'modules') { + splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl]; + push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; + } + else { + splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl]; + push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports; + } + + push @full_reports, "\n"; + } + } +} + +if ( @full_reports ) { + diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; +} + +if ( $cpan_meta_error || @dep_errors ) { + diag "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n"; +} + +if ( $cpan_meta_error ) { + my ($orig_source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; + diag "\nCPAN::Meta->load_file('$orig_source') failed with: $cpan_meta_error\n"; +} + +if ( @dep_errors ) { + diag join("\n", + "\nThe following REQUIRED prerequisites were not satisfied:\n", + @dep_errors, + "\n" + ); +} + +pass('Reported prereqs'); + +# vim: ts=4 sts=4 sw=4 et: diff --git a/t/crypt.t b/t/crypt.t new file mode 100644 index 0000000..c003a5f --- /dev/null +++ b/t/crypt.t @@ -0,0 +1,82 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use Crypt::Misc 0.029 qw(decode_b64 encode_b64); +use File::KDBX::Cipher; +use File::KDBX::Constants qw(CIPHER_UUID_AES256); +use File::KDBX::IO::Crypt; +use IO::Handle; +use Test::More; + +subtest 'Round-trip block stream' => sub { + plan tests => 3; + my $block_cipher = File::KDBX::Cipher->new(uuid => CIPHER_UUID_AES256, key => 0x01 x 32, iv => 0x01 x 16); + test_roundtrip($block_cipher, + 'Smell the pretty flowers.', + decode_b64('pB10mV+mhTuh7bKg0KEUl5H1ajFMaP4uPnTZNcDgq6s='), + ); +}; + +subtest 'Round-trip cipher stream' => sub { + plan tests => 3; + my $cipher_stream = File::KDBX::Cipher->new(stream_id => 2, key => 0x01 x 16); + test_roundtrip($cipher_stream, + 'Smell the pretty flowers.', + decode_b64('gNj2Ud9tWtFDy+xDN/U01RxmCoI6MAlTKQ=='), + ); +}; + +subtest 'Error handling' => sub { + plan tests => 4; + + my $block_cipher = File::KDBX::Cipher->new(uuid => CIPHER_UUID_AES256, key => 0x01 x 32, iv => 0x01 x 16); + pipe(my $read, my $write) or die "pipe failed: $!"; + $read = File::KDBX::IO::Crypt->new($read, cipher => $block_cipher); + + print $write "blah blah blah!\1"; + close($write) or die "close failed: $!"; + + is $read->error, '', 'Read handle starts out fine'; + my $plaintext = do { local $/; <$read> }; + is $plaintext, '', 'Read can fail'; + is $read->error, 1, 'Read handle can enter an error state'; + + like $File::KDBX::IO::Crypt::ERROR, qr/fatal/i, + 'Error object is available'; +}; + +done_testing; +exit; + +sub test_roundtrip { + my $cipher = shift; + my $expected_plaintext = shift; + my $expected_ciphertext = shift; + + pipe(my $read, my $write) or die "pipe failed: $!"; + $write = File::KDBX::IO::Crypt->new($write, cipher => $cipher); + + print $write $expected_plaintext; + close($write) or die "close failed: $!"; + + my $ciphertext = do { local $/; <$read> }; + close($read); + is $ciphertext, $expected_ciphertext, 'Encrypted a string' + or diag encode_b64($ciphertext); + + my $ciphertext2 = $cipher->encrypt_finish($expected_plaintext); + is $ciphertext, $ciphertext2, 'Same result'; + + open(my $fh, '<', \$ciphertext) or die "open failed: $!\n"; + $fh = File::KDBX::IO::Crypt->new($fh, cipher => $cipher); + + my $plaintext = do { local $/; <$fh> }; + close($fh); + is $plaintext, $expected_plaintext, 'Decrypted a string' + or diag encode_b64($plaintext); +} diff --git a/t/database.t b/t/database.t new file mode 100644 index 0000000..d4edfb2 --- /dev/null +++ b/t/database.t @@ -0,0 +1,173 @@ +#!/usr/bin/env perl + +use utf8; +use warnings; +use strict; + +use FindBin qw($Bin); +use lib "$Bin/lib"; +use TestCommon; + +use File::KDBX; +use Test::Deep; +use Test::More; +use Time::Piece; + +subtest 'Create a new database' => sub { + my $kdbx = File::KDBX->new; + + $kdbx->add_group(name => 'Meh'); + ok $kdbx->_has_implicit_root, 'Database starts off with implicit root'; + + my $entry = $kdbx->add_entry({ + username => 'hello', + password => {value => 'This is a secret!!!!!', protect => 1}, + }); + + ok !$kdbx->_has_implicit_root, 'Adding an entry to the root group makes it explicit'; + + $entry->remove; + ok $kdbx->_has_implicit_root, 'Removing group makes the root group implicit again'; +}; + +subtest 'Clone' => sub { + my $kdbx = File::KDBX->new; + $kdbx->add_group(name => 'Passwords')->add_entry(title => 'My Entry'); + + my $copy = $kdbx->clone; + cmp_deeply $copy, $kdbx, 'Clone keeps the same structure and data' or dumper $copy; + + isnt $kdbx, $copy, 'Clone is a different object'; + isnt $kdbx->root, $copy->root, + 'Clone root group is a different object'; + isnt $kdbx->root->groups->[0], $copy->root->groups->[0], + 'Clone group is a different object'; + isnt $kdbx->root->groups->[0]->entries->[0], $copy->root->groups->[0]->entries->[0], + 'Clone entry is a different object'; + + my @objects = $copy->objects->each; + subtest 'Cloned objects refer to the cloned database' => sub { + plan tests => scalar @_; + for my $object (@objects) { + my $object_kdbx = eval { $object->kdbx }; + is $object_kdbx, $copy, 'Object: ' . $object->label; + } + }, @objects; +}; + +subtest 'Iteration algorithm' => sub { + # Database + # - Root + # - Group1 + # - EntryA + # - Group2 + # - EntryB + # - Group3 + # - EntryC + my $kdbx = File::KDBX->new; + my $group1 = $kdbx->add_group(label => 'Group1'); + my $group2 = $group1->add_group(label => 'Group2'); + my $group3 = $kdbx->add_group(label => 'Group3'); + my $entry1 = $group1->add_entry(label => 'EntryA'); + my $entry2 = $group2->add_entry(label => 'EntryB'); + my $entry3 = $group3->add_entry(label => 'EntryC'); + + cmp_deeply $kdbx->groups->map(sub { $_->label })->to_array, + [qw(Root Group1 Group2 Group3)], 'Default group order'; + cmp_deeply $kdbx->entries->map(sub { $_->label })->to_array, + [qw(EntryA EntryB EntryC)], 'Default entry order'; + cmp_deeply $kdbx->objects->map(sub { $_->label })->to_array, + [qw(Root Group1 EntryA Group2 EntryB Group3 EntryC)], 'Default object order'; + + cmp_deeply $kdbx->groups(algorithm => 'ids')->map(sub { $_->label })->to_array, + [qw(Root Group1 Group2 Group3)], 'IDS group order'; + cmp_deeply $kdbx->entries(algorithm => 'ids')->map(sub { $_->label })->to_array, + [qw(EntryA EntryB EntryC)], 'IDS entry order'; + cmp_deeply $kdbx->objects(algorithm => 'ids')->map(sub { $_->label })->to_array, + [qw(Root Group1 EntryA Group2 EntryB Group3 EntryC)], 'IDS object order'; + + cmp_deeply $kdbx->groups(algorithm => 'dfs')->map(sub { $_->label })->to_array, + [qw(Group2 Group1 Group3 Root)], 'DFS group order'; + cmp_deeply $kdbx->entries(algorithm => 'dfs')->map(sub { $_->label })->to_array, + [qw(EntryB EntryA EntryC)], 'DFS entry order'; + cmp_deeply $kdbx->objects(algorithm => 'dfs')->map(sub { $_->label })->to_array, + [qw(Group2 EntryB Group1 EntryA Group3 EntryC Root)], 'DFS object order'; + + cmp_deeply $kdbx->groups(algorithm => 'bfs')->map(sub { $_->label })->to_array, + [qw(Root Group1 Group3 Group2)], 'BFS group order'; + cmp_deeply $kdbx->entries(algorithm => 'bfs')->map(sub { $_->label })->to_array, + [qw(EntryA EntryC EntryB)], 'BFS entry order'; + cmp_deeply $kdbx->objects(algorithm => 'bfs')->map(sub { $_->label })->to_array, + [qw(Root Group1 EntryA Group3 EntryC Group2 EntryB)], 'BFS object order'; +}; + +subtest 'Recycle bin' => sub { + my $kdbx = File::KDBX->new; + my $entry = $kdbx->add_entry(label => 'Meh'); + + my $bin = $kdbx->groups->grep(name => 'Recycle Bin')->next; + ok !$bin, 'New database has no recycle bin'; + + is $kdbx->recycle_bin_enabled, 1, 'Recycle bin is enabled'; + $kdbx->recycle_bin_enabled(0); + + $entry->recycle_or_remove; + cmp_ok $entry->is_recycled, '==', 0, 'Entry is not recycle if recycle bin is disabled'; + + $bin = $kdbx->groups->grep(name => 'Recycle Bin')->next; + ok !$bin, 'Recycle bin not autovivified if recycle bin is disabled'; + is $kdbx->entries->size, 0, 'Database is empty after removing entry'; + + $kdbx->recycle_bin_enabled(1); + + $entry = $kdbx->add_entry(label => 'Another one'); + $entry->recycle_or_remove; + cmp_ok $entry->is_recycled, '==', 1, 'Entry is recycled'; + + $bin = $kdbx->groups->grep(name => 'Recycle Bin')->next; + ok $bin, 'Recycle bin group autovivifies'; + cmp_ok $bin->icon_id, '==', 43, 'Recycle bin has the trash icon'; + cmp_ok $bin->enable_auto_type, '==', 0, 'Recycle bin has auto type disabled'; + cmp_ok $bin->enable_searching, '==', 0, 'Recycle bin has searching disabled'; + + is $kdbx->entries->size, 1, 'Database is not empty'; + is $kdbx->entries(searching => 1)->size, 0, 'Database has no entries if searching'; + cmp_ok $bin->entries_deeply->size, '==', 1, 'Recycle bin has an entry'; + + $entry->recycle_or_remove; + is $kdbx->entries->size, 0, 'Remove entry if it is already in the recycle bin'; +}; + +subtest 'Maintenance' => sub { + my $kdbx = File::KDBX->new; + $kdbx->add_group; + $kdbx->add_group->add_group; + my $entry = $kdbx->add_group->add_entry; + + cmp_ok $kdbx->remove_empty_groups, '==', 3, 'Remove two empty groups'; + cmp_ok $kdbx->groups->count, '==', 2, 'Two groups remain'; + + $entry->begin_work; + $entry->commit; + cmp_ok $kdbx->prune_history(max_age => 5), '==', 0, 'Do not remove new historical entries'; + + $entry->begin_work; + $entry->commit; + $entry->history->[0]->last_modification_time(scalar gmtime - 86400 * 10); + cmp_ok $kdbx->prune_history(max_age => 5), '==', 1, 'Remove a historical entry'; + cmp_ok scalar @{$entry->history}, '==', 1, 'One historical entry remains'; + + cmp_ok $kdbx->remove_unused_icons, '==', 0, 'No icons to remove'; + $kdbx->add_custom_icon('fake image 1'); + $kdbx->add_custom_icon('fake image 2'); + $entry->custom_icon('fake image 3'); + cmp_ok $kdbx->remove_unused_icons, '==', 2, 'Remove unused icons'; + cmp_ok scalar @{$kdbx->custom_icons}, '==', 1, 'Only one icon remains'; + + my $icon_uuid = $kdbx->add_custom_icon('fake image'); + $entry->custom_icon('fake image'); + cmp_ok $kdbx->remove_duplicate_icons, '==', 1, 'Remove duplicate icons'; + is $entry->custom_icon_uuid, $icon_uuid, 'Uses of removed icon change'; +}; + +done_testing; diff --git a/t/entry.t b/t/entry.t new file mode 100644 index 0000000..f08b683 --- /dev/null +++ b/t/entry.t @@ -0,0 +1,172 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Entry; +use File::KDBX; +use Test::Deep; +use Test::More; + +subtest 'Construction' => sub { + my $entry = File::KDBX::Entry->new(my $data = {username => 'foo'}); + is $entry, $data, 'Provided data structure becomes the object'; + isa_ok $data, 'File::KDBX::Entry', 'Data structure is blessed'; + is $entry->{username}, 'foo', 'username is in the object still'; + is $entry->username, '', 'username is not the UserName string'; + + like exception { $entry->kdbx }, qr/disconnected/, 'Dies if disconnected'; + $entry->kdbx(my $kdbx = File::KDBX->new); + is $entry->kdbx, $kdbx, 'Set a database after instantiation'; + + is_deeply $entry, {username => 'foo', strings => {UserName => {value => ''}}}, + 'Entry data contains what was provided to the constructor plus vivified username'; + + $entry = File::KDBX::Entry->new(username => 'bar'); + is $entry->{username}, undef, 'username is not set on the data'; + is $entry->username, 'bar', 'username is set correctly as the UserName string'; + + cmp_deeply $entry, noclass({ + auto_type => { + associations => [], + data_transfer_obfuscation => 0, + default_sequence => "{USERNAME}{TAB}{PASSWORD}{ENTER}", + enabled => bool(1), + }, + background_color => "", + binaries => {}, + custom_data => {}, + custom_icon_uuid => undef, + foreground_color => "", + history => [], + icon_id => "Password", + override_url => "", + previous_parent_group => undef, + quality_check => bool(1), + strings => { + Notes => { + value => "", + }, + Password => { + protect => bool(1), + value => "", + }, + Title => { + value => "", + }, + URL => { + value => "", + }, + UserName => { + value => "bar", + }, + }, + tags => "", + times => { + last_modification_time => isa('Time::Piece'), + creation_time => isa('Time::Piece'), + last_access_time => isa('Time::Piece'), + expiry_time => isa('Time::Piece'), + expires => bool(0), + usage_count => 0, + location_changed => isa('Time::Piece'), + }, + uuid => re('^(?s:.){16}$'), + }), 'Entry data contains UserName string and the rest default attributes'; +}; + +subtest 'Accessors' => sub { + my $entry = File::KDBX::Entry->new; + + $entry->creation_time('2022-02-02 12:34:56'); + cmp_ok $entry->creation_time, '==', 1643805296, 'Creation time coerced into a Time::Piece (epoch)'; + is $entry->creation_time->datetime, '2022-02-02T12:34:56', 'Creation time coerced into a Time::Piece'; +}; + +subtest 'Custom icons' => sub { + plan tests => 10; + my $gif = pack('H*', '4749463839610100010000ff002c00000000010001000002003b'); + + my $entry = File::KDBX::Entry->new(my $kdbx = File::KDBX->new, icon_id => 42); + is $entry->custom_icon_uuid, undef, 'UUID is undef if no custom icon is set'; + is $entry->custom_icon, undef, 'Icon is undef if no custom icon is set'; + is $entry->icon_id, 'KCMMemory', 'Default icon is set to something'; + + is $entry->custom_icon($gif), $gif, 'Setting a custom icon returns icon'; + is $entry->custom_icon, $gif, 'Henceforth the icon is set'; + is $entry->icon_id, 'Password', 'Default icon got changed to first icon'; + my $uuid = $entry->custom_icon_uuid; + isnt $uuid, undef, 'UUID is now set'; + + my $found = $entry->kdbx->custom_icon_data($uuid); + is $entry->custom_icon, $found, 'Custom icon on entry matches the database'; + + is $entry->custom_icon(undef), undef, 'Unsetting a custom icon returns undefined'; + $found = $entry->kdbx->custom_icon_data($uuid); + is $found, $gif, 'Custom icon still exists in the database'; +}; + +subtest 'History' => sub { + my $kdbx = File::KDBX->new; + my $entry = $kdbx->add_entry(label => 'Foo'); + is scalar @{$entry->history}, 0, 'New entry starts with no history'; + is $entry->current_entry, $entry, 'Current new entry is itself'; + ok $entry->is_current, 'New entry is current'; + + my $txn = $entry->begin_work; + $entry->notes('Hello!'); + $txn->commit; + is scalar @{$entry->history}, 1, 'Committing creates a historical entry'; + ok $entry->is_current, 'New entry is still current'; + ok $entry->history->[0]->is_historical, 'Historical entry is not current'; + is $entry->notes, 'Hello!', 'New entry is modified after commit'; + is $entry->history->[0]->notes, '', 'Historical entry is saved without modification'; +}; + +subtest 'Update UUID' => sub { + my $kdbx = File::KDBX->new; + + my $entry1 = $kdbx->add_entry(label => 'Foo'); + my $entry2 = $kdbx->add_entry(label => 'Bar'); + + $entry2->url(sprintf('{REF:T@I:%s} {REF:T@I:%s}', $entry1->id, lc($entry1->id))); + is $entry2->expand_url, 'Foo Foo', 'Field reference expands' + or diag explain $entry2->url; + + $entry1->uuid("\1" x 16); + + is $entry2->url, '{REF:T@I:01010101010101010101010101010101} {REF:T@I:01010101010101010101010101010101}', + 'Replace field references when an entry UUID is changed'; + is $entry2->expand_url, 'Foo Foo', 'Field reference expands after UUID is changed' + or diag explain $entry2->url; +}; + +subtest 'Auto-type' => sub { + my $kdbx = File::KDBX->new; + + my $entry = $kdbx->add_entry(title => 'Meh'); + $entry->add_auto_type_association({ + window => 'Boring Store', + keystroke_sequence => 'yeesh', + }); + $entry->add_auto_type_association({ + window => 'Friendly Bank', + keystroke_sequence => 'blah', + }); + + my $window_title = 'Friendly'; + my $entries = $kdbx->entries(auto_type => 1) + ->filter(sub { + my ($ata) = grep { $_->{window} =~ /\Q$window_title\E/i } @{$_->auto_type_associations}; + return [$_, $ata->{keystroke_sequence} || $_->auto_type_default_sequence] if $ata; + }); + cmp_ok $entries->count, '==', 1, 'Find auto-type window association'; + + (undef, my $keys) = @{$entries->next}; + is $keys, 'blah', 'Select the correct association'; +}; + +done_testing; diff --git a/t/erase.t b/t/erase.t new file mode 100644 index 0000000..46454ae --- /dev/null +++ b/t/erase.t @@ -0,0 +1,47 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Util qw(:erase); +use Test::More; + +my $data1 = 'hello'; +my $data2 = 'hello'; +my $hash1 = {foo => 'secret'}; +my $array1 = [qw(bar baz)]; + +erase $data1, \$data2, $hash1, $array1; +is $data1, undef, 'Erase by alias'; +is $data2, undef, 'Erase by reference'; +is scalar keys %$hash1, 0, 'Erase by hashref'; +is scalar @$array1, 0, 'Erase by arrayref'; + +{ + my $data3 = 'hello'; + my $cleanup = erase_scoped $data3; + is $data3, 'hello', 'Data not yet erased'; + undef $cleanup; + is $data3, undef, 'Scoped erased'; +} + +sub get_secret { + my $secret = 'conspiracy'; + my $cleanup = erase_scoped \$secret; + return $secret; +} + +my $another; +{ + my $thing = get_secret(); + $another = $thing; + is $thing, 'conspiracy', 'Data not yet erased'; + undef $thing; + is $thing, undef, 'Scope erased'; +} +is $another, 'conspiracy', 'Data not erased in the other scalar'; + +done_testing; diff --git a/t/error.t b/t/error.t new file mode 100644 index 0000000..fabaa17 --- /dev/null +++ b/t/error.t @@ -0,0 +1,105 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +BEGIN { delete $ENV{DEBUG} } + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Error; +use File::KDBX; +use Test::More; + +subtest 'Errors' => sub { + my $error = exception { + local $! = 1; + $@ = 'last exception'; + throw 'uh oh', foo => 'bar'; + }; + like $error, qr/uh oh/, 'Errors can be thrown using the "throw" function'; + + $error = exception { $error->throw }; + like $error, qr/uh oh/, 'Errors can be rethrown'; + + is $error->details->{foo}, 'bar', 'Errors can have details'; + is $error->errno+0, 1, 'Errors record copy of errno when thrown'; + is $error->previous, 'last exception', 'Warnings record copy of the last exception'; + + my $trace = $error->trace; + ok 0 < @$trace, 'Errors record a stacktrace'; + like $trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct'; + + $error = exception { File::KDBX::Error->throw('uh oh') }; + like $error, qr/uh oh/, 'Errors can be thrown using the "throw" constructor'; + like $error->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct'; + + $error = File::KDBX::Error->new('uh oh'); + $error = exception { $error->throw }; + like $error, qr/uh oh/, 'Errors can be thrown using the "throw" method'; + like $error->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct'; +}; + +subtest 'Warnings' => sub { + my $warning = warning { + local $! = 1; + $@ = 'last exception'; + alert 'uh oh', foo => 'bar'; + }; + like $warning, qr/uh oh/, 'Warnings are enabled by default' or diag 'Warnings: ', explain $warning; + + SKIP: { + skip 'Warning object requires Perl 5.14 or later' if $] < 5.014; + is $warning->details->{foo}, 'bar', 'Warnings can have details'; + is $warning->errno+0, 1, 'Warnings record copy of errno when logged'; + is $warning->previous, 'last exception', 'Warnings record copy of the last exception'; + like $warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct'; + }; + + $warning = warning { File::KDBX::Error->warn('uh oh') }; + like $warning, qr/uh oh/, 'Warnings can be logged using the "alert" constructor'; + SKIP: { + skip 'Warning object requires Perl 5.14 or later' if $] < 5.014; + like $warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct'; + }; + + my $error = File::KDBX::Error->new('uh oh'); + $warning = warning { $error->alert }; + like $warning, qr/uh oh/, 'Warnings can be logged using the "alert" method'; + SKIP: { + skip 'Warning object requires Perl 5.14 or later' if $] < 5.014; + like $warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct'; + }; + + { + local $File::KDBX::WARNINGS = 0; + my @warnings = warnings { alert 'uh oh' }; + is @warnings, 0, 'Warnings can be disabled locally' + or diag 'Warnings: ', explain(\@warnings); + } + + SKIP: { + skip 'warnings::warnif_at_level is required', 1 if !warnings->can('warnif_at_level'); + no warnings 'File::KDBX'; + my @warnings = warnings { alert 'uh oh' }; + is @warnings, 0, 'Warnings can be disabled lexically' + or diag 'Warnings: ', explain(\@warnings); + } + + SKIP: { + skip 'warnings::fatal_enabled_at_level is required', 1 if !warnings->can('fatal_enabled_at_level'); + use warnings FATAL => 'File::KDBX'; + my $exception = exception { alert 'uh oh' }; + like $exception, qr/uh oh/, 'Warnings can be fatal'; + } + + { + my $warning; + local $SIG{__WARN__} = sub { $warning = shift }; + alert 'uh oh'; + like $warning, qr/uh oh/, 'Warnings can be caught'; + } +}; + +done_testing; diff --git a/t/files/BrokenHeaderHash.kdbx b/t/files/BrokenHeaderHash.kdbx new file mode 100644 index 0000000000000000000000000000000000000000..6c4c43991479aab7c4fbcbd0ec7168edae72c8a4 GIT binary patch literal 1982 zcmV;v2SNA)*`k_f`%AR}00RI55CAd3^5(yBLr}h01tDtuTK@wC0096100bZa5H_T> zgKaT1uT=VP4!OqXjrIP-5bospGXul(2L*-I1t0(eA(&`*^N?;<6X4FWh!$E0Y(L|m zu+_2|X_I*f#^hE82mo*w00000000LN09q)^;)-|-*3#n3(CX|uQwSgcE1HwS5ZkQc zSw#69`z*pb!>0)rBnS9s%o<9d`8!pd2_OJzB}{G@4Y7(*wg`b6bmD`9{QO13+P}~X z#9@<-BYw6D1ONg60000401XNa3SD<8*H{FLuhqA{>Ogogde_Zc|8gQ%?V&Xz|Ag^u zUdbZH@-g6LQu+<gG`9Xr%t$xHCz38SyVsQ9IO`T!PhS^nFb!3v^+l_QOLg{yK$vrv zy){!=U#BojkYmIBhxnZ4_3IH>f?=jOW;N~G>)`Ab>F`w7!O8o3Cv2ZDk6_(mV#ESS zA<!hcR~pc7W5ey#{`pTSzL=!ct{9;4Pm}ZAbL7{ZgfQRI)-enClNN0(^-78nXg*VM zea3z#s7gD7Bl2N-YI^<XBR)ec4rN`{!R3MyzN9EXHbO%8I|G(TdLvm&#U{GiuFm(u z<TWGD{C)JK-8cVfT|J_iJChh$mg}TycOfR<GT3Bvi`0Npw2<<1xDl(L7}{2EbDUN* zL9ZJ28j#lwsw@k$sn@c+6?@=NWnPrDD}d+#qv)dcMBOCMon`4G<Ek(rYleS1=hO3M z8d&2gEj)?WbG#w8@3JPJM)?<$r%|d$vDRa8HR9{zh^_-F=3FaH+qXc#!C9xB+RL;? z!B=H3Qf|bqlS3OPb}e1fVLlFbyTus!`w4Xpr)!5tl_>f7B}%D>MoCL4%aII2a1Aa; ztkIV@5jiZhQ&8VX)+%gT=cZ1RC^5%EIF*7VZQ2T@HObb+KP9Uz5DxB)ZNMy@!>#bg zlK`<{U%4Nd*>D82JdP(ZHIorInGmDQ-R7oSAF!Ea498?jLNfYP;v2JmBbGDf%D5g% z>7*6qjtgVoMaD$<aIC3Y49J9t3A`Z*%8b(dBIS+vn00=OW1SyzP$Orj;h(jgMy8}= z`Vp`IJn5y61yEiP%OuHcTji$>Rp!rfPbd>*PX7N$zIQ?26%u+DINX^+!hHDRUF22% zOA=s6^^MGNfg1?l6E_U48*s+&<#{i*ev1qAeJP@?oZi}lRY}tPwU3#+3P#yno73mm zla0-VWF~XBkeGOaYsHC4$x=uH;n?jUYiFo>bs$=*$VlWrrHjA>Ae`*?nHHl&0BqRW zrQx_hl<<sfzK75GH6r}}-{<nk!bPWRI+oPQ^<4JY`vNfpl_&vO3-kZlE~N*61%X$$ zw*~_c$j^af<?X$<hHbq8kBF37ff)97Tv{It_rpQeA+Qd`FDYH_0V#RR`n0q>`IAsC zoYG&P$+Dsr^4$S<v1CiR;+9WO*ca($XzT&Q^J#z)O*7`(0TVniX~v0~I-_&Fz1q2a z+}By<VY{x3nXH1~lM$%&v|s`|;}~6;KMM%Nzn+Vi_&C%}pX?81wtB#IumjD;s6gm; zp)W&4Vely89HsLQ5ij-BOL8;U>+-Ps02nt9CT0WY8BS0v_cvjxT5Vrx*9xX8y7}a> zhnlugKyv;GO(J&EdYH#NaCGQ*g44|yo$gnZ>Se$q&F7FvrJ~&10RaJAG+e!e)1g+y zGvZ(KQUScgY>8!{Cb)ASHp!YjS<St*ObLSz#U4>zR1@D^s#1VE#id(qb!Nk4r70#0 zEt0}2S)~5857J2SuyvE8gK(bNIf3b9$P-NBbKB`8t9up|g}l5-l>!>jYDz68(Yl7l zT+q{!yFp+PEz=q@P+^tIVx^j%Ww~ec9_5TIj$I#~%&*K$*L&-Mh|!~8)YJnSltZdz zRkmC56)X30t{s&hZc!FM8;>1}R+<Xggd?6koIaFyulJ7h*;`G?Upt;UF*=3aiso00 znAb7QAm~FJpW`cVxizbO<Q$rXdAj4C{v%6~H$#A#>z4TwnGLwqLgMAr;FX}=u?~)d z+CBTK#Sv?YH;5{`%|m|*3+gC@o1KJZN?aLF8CJkB*LzoaDpHK=$j}*}D#4_T60PjB zQ0?T<*csZvyM*;y)uIPlp+GKJob)~ewr{AVtnBb24_mG!Q2(#GyYIw#Dt(`pdqMQj z#MAAdcr6NeG?7U+XrFqah#RuuW#RDbZx(&c95rCM%YEOZB2}j@UJ}kqR2C^8*?dH= z9M6016i^<twz#RNF`C!lPp@?F#V-kQGaVWKO|@H4biwYR6zmSET5$bazz(MZ1#ynV zL&XCAd-Zke=vmfG2<&Rqk31Z8Mg)(NY0t+(C)+t`dyLr{(~#bXJUphY1mn*XujBI~ z6fgO$q@hOMxafRcjp--8U{eQt=sdgz3Fsm36s};Rs{sxQ-Yl`R$a=<?hMPGO*UafX zB?tgY31dDt(qtzT=b&oy^}Fj(uQnuk;WgCADhGu=D~_a11=XCc=gp1fr225C>W0KZ z6Rm(|a{3F<(vW68w7@X=9qWp~niwyP1-a>q4k4`8{vO@D?Q^}i#n5MX(sK|1q%q;c QLO=%s2m2v%Emfv*CucFy%m4rY literal 0 HcmV?d00001 diff --git a/t/files/CP-1252.kdb b/t/files/CP-1252.kdb new file mode 100644 index 0000000000000000000000000000000000000000..707bc458ede716e7b41ece050b7211410423e4ae GIT binary patch literal 620 zcmV-y0+am%*`k_d`%AS00000200RK#^e#+mRri1&wkmw|`ZD#oNn8%O_S<E$pxe0D zz9`}W000020001Kl_+NMH1CIjQQET@sd_bINVfCCs?4pXJ_IVE=$4_8zvvXcnXR}X z+{24FOqIKGuMBmBuA2O2y_=;qAy9G(0002J-to6nO)Gyst930lG6^!}nQW%Y;=MMa zUQ%1;#0(uRp))xJ&c#VqjjXZ9Yj1$uBsr3z1zsD)E9+(jJu@;;%SE-|6&uy)`oKBf z#)2sIx?hpvqgl3E>=M-?<BV~ZP^ux-88UWV6D|(TG&1KLN-g>0^kbdye>|n>yHnSB z5(Nc@ujL+ZC8{0a=a&DDePZEYI;>{(I6WiI_6mMQ?iHW+xl;Pu5-e!dY$AH6<9<Dn zCH!DT4R6~@uK3LY&@B}dc89sJQaku0rU!x+2^Zrv0Dg8>4Ph7|pQq0@(@#x;gx#rd z{<HZM`_9)wXE)OMN}q+da_Qpfq=4t+u-7BgExO6xmqXnuD`Twnp>X!o2?F_8hK1~w z!}u%>=83wgxWrEf!!#8#aPaybNPhPBB=ZKCC2-YCW22U9(0!h*2Efnhp#*pV$9V)A z12q_mDsU)#q%KQq-)Y;Ut^1zYv-WSuCp|SpWRT7qs#l9%5L4=VL&k(L?2BnTE?gPt z&?HD5q>oW16&A%0Q%z6`z!@JQy|(P)AumpusUPv{a(<Cf{_BOa(|_PJ9}^P^3A`7l z<)PZ9e}Wj#;1Gy)CU2XEOK`Z}1|e93I{}<(2T({LBgKv+UH~&t#dvbYPXyg~e`nxZ Gh>+vDpDJSj literal 0 HcmV?d00001 diff --git a/t/files/CompositeKey.kdb b/t/files/CompositeKey.kdb new file mode 100644 index 0000000000000000000000000000000000000000..70060d8f2251a3db585cef9224b76377d7d78a01 GIT binary patch literal 636 zcmV-?0)zbn*`k_d`%AS00000200RJhLUoW;eviuwp7fvJkJ$wD_l1xPzEASdLC0#Q z#&N#^000020001}icMIGPEPZwYJ#?U*oJ@z<itnWu-6enE&lvqi{hCUJSQ;C6Vf8M z`SI9zAd_$o5~B82w6_r!;+XQC^P*N{00029qs|yX+z=?aD)C>`nc8JDFK5B5VkHzS z!=5bj<z~2eqKGp;W?x04;!l+hv!w6@3UiXht-=a8&2S)-*1f$`)r9ZaMLa1mjRqp* z{ZhfxP03O)5tpCzZ@cm3Se%^?U%cwAp~>Q<AfuJl&4qztKj5!w5Tdxd73c??`&)h7 z=Z|YB$-4#Y;;X8W!Q7ec-p*Eb34g5*5O8yv<<z0$YfP@KwM4>6=Yu;Ur_KsjJtr3I z$au7Y15!l%&cd2|(=}FPH1-fJr;0I#Tg1=@M;#<0MuYUcwCP`mcDEX{lG@dSM@Yt> zm}vAM>DJ^PA6(u7V-X4!bML1TG?({<iz%gOnk3sxf0;*?B$H%F6;vwgL!vM_l>cT; z!F!yQebEybDa%$dz1)yAW3}`DG<s)G?DX#aWp2x_6gx}+(%gO_v#!5GBbXt;{3!-p z)Ipmp_MU9N57|_3SNSTMU_l@em8J|gdfE+6>BRjR@LUjs{;ixA#J5liEDewyCOP&L zHuZ5=pwD>^1AJc6(%?TTgEBsF%J@Ry^pH{MvVW!c`VopCw>0C!jTR3!p`5)3*o<~E z+Ncbg+G*krXd=!%i}fTT=1C0h;~iSTS8GYpLs7D5gq^*FKCAEnY=uH6hvH0d+XY|} W)OqW0Kg}p!B#V}eVr)qbskOZQeK_6# literal 0 HcmV?d00001 diff --git a/t/files/Compressed.kdbx b/t/files/Compressed.kdbx new file mode 100644 index 0000000000000000000000000000000000000000..1f8ec2de6871a80cc65cf7e42e38efb5881a9ef3 GIT binary patch literal 1982 zcmV;v2SNA)*`k_f`%AR}00RI55CAd3^5(yBLr}h01tDtuTK@wC0096100bZa5H_T> zgKaT1uT=VP4!OqXjrIP-5bospGXul(2L*-I1t0(eA(&`*^N?;<6X4FWh!$E0Y(L|m zu+_2|X_I*f#^hE82mo*w00000000LN09q)^;)-|-*3#n3(CX|uQwSgcE1HtR5ZkQc zSw#69`z*pb!>0)rBnS9s%o<9d`8!pd2_OJzB}{G@4Y7(*wg`b6bmD`9{QO13+P}~X z#9@<-BYw6D1ONg60000401XNa3SD<8*H{FLuhqA{>Ogogde_Zc|8gQ%?V&Xz|Ag^u zUdbZH@-g6LQu+<gG`9Xr%t$xHCz38SyVsQ9IO`T!PhS^nFb!3v^+l_QOLg{yK$vrv zy){!=U#BojkYmIBhxnZ4_3IH>f?=jOW;N~G>)`Ab>F`w7!O8o3Cv2ZDk6_(mV#ESS zA<!hcR~pc7W5ey#{`pTSzL=!ct{9;4Pm}ZAbL7{ZgfQRI)-enClNN0(^-78nXg*VM zea3z#s7gD7Bl2N-YI^<XBR)ec4rN`{!R3MyzN9EXHbO%8I|G(TdLvm&#U{GiuFm(u z<TWGD{C)JK-8cVfT|J_iJChh$mg}TycOfR<GT3Bvi`0Npw2<<1xDl(L7}{2EbDUN* zL9ZJ28j#lwsw@k$sn@c+6?@=NWnPrDD}d+#qv)dcMBOCMon`4G<Ek(rYleS1=hO3M z8d&2gEj)?WbG#w8@3JPJM)?<$r%|d$vDRa8HR9{zh^_-F=3FaH+qXc#!C9xB+RL;? z!B=H3Qf|bqlS3OPb}e1fVLlFbyTus!`w4Xpr)!5tl_>f7B}%D>MoCL4%aII2a1Aa; ztkIV@5jiZhQ&8VX)+%gT=cZ1RC^5%EIF*7VZQ2T@HObb+KP9Uz5DxB)ZNMy@!>#bg zlK`<{U%4Nd*>D82JdP(ZHIorInGmDQ-R7oSAF!Ea498?jLNfYP;v2JmBbGDf%D5g% z>7*6qjtgVoMaD$<aIC3Y49J9t3A`Z*%8b(dBIS+vn00=OW1SyzP$Orj;h(jgMy8}= z`Vp`IJn5y61yEiP%OuHcTji$>Rp!rfPbd>*PX7N$zIQ?26%u+DINX^+!hHDRUF22% zOA=s6^^MGNfg1?l6E_U48*s+&<#{i*ev1qAeJP@?oZi}lRY}tPwU3#+3P#yno73mm zla0-VWF~XBkeGOaYsHC4$x=uH;n?jUYiFo>bs$=*$VlWrrHjA>Ae`*?nHHl&0BqRW zrQx_hl<<sfzK75GH6r}}-{<nk!bPWRI+oPQ^<4JY`vNfpl_&vO3-kZlE~N*61%X$$ zw*~_c$j^af<?X$<hHbq8kBF37ff)97Tv{It_rpQeA+Qd`FDYH_0V#RR`n0q>`IAsC zoYG&P$+Dsr^4$S<v1CiR;+9WO*ca($XzT&Q^J#z)O*7`(0TVniX~v0~I-_&Fz1q2a z+}By<VY{x3nXH1~lM$%&v|s`|;}~6;KMM%Nzn+Vi_&C%}pX?81wtB#IumjD;s6gm; zp)W&4Vely89HsLQ5ij-BOL8;U>+-Ps02nt9CT0WY8BS0v_cvjxT5Vrx*9xX8y7}a> zhnlugKyv;GO(J&EdYH#NaCGQ*g44|yo$gnZ>Se$q&F7FvrJ~&10RaJAG+e!e)1g+y zGvZ(KQUScgY>8!{Cb)ASHp!YjS<St*ObLSz#U4>zR1@D^s#1VE#id(qb!Nk4r70#0 zEt0}2S)~5857J2SuyvE8gK(bNIf3b9$P-NBbKB`8t9up|g}l5-l>!>jYDz68(Yl7l zT+q{!yFp+PEz=q@P+^tIVx^j%Ww~ec9_5TIj$I#~%&*K$*L&-Mh|!~8)YJnSltZdz zRkmC56)X30t{s&hZc!FM8;>1}R+<Xggd?6koIaFyulJ7h*;`G?Upt;UF*=3aiso00 znAb7QAm~FJpW`cVxizbO<Q$rXdAj4C{v%6~H$#A#>z4TwnGLwqLgMAr;FX}=u?~)d z+CBTK#Sv?YH;5{`%|m|*3+gC@o1KJZN?aLF8CJkB*LzoaDpHK=$j}*}D#4_T60PjB zQ0?T<*csZvyM*;y)uIPlp+GKJob)~ewr{AVtnBb24_mG!Q2(#GyYIw#Dt(`pdqMQj z#MAAdcr6NeG?7U+XrFqah#RuuW#RDbZx(&c95rCM%YEOZB2}j@UJ}kqR2C^8*?dH= z9M6016i^<twz#RNF`C!lPp@?F#V-kQGaVWKO|@H4biwYR6zmSET5$bazz(MZ1#ynV zL&XCAd-Zke=vmfG2<&Rqk31Z8Mg)(NY0t+(C)+t`dyLr{(~#bXJUphY1mn*XujBI~ z6fgO$q@hOMxafRcjp--8U{eQt=sdgz3Fsm36s};Rs{sxQ-Yl`R$a=<?hMPGO*UafX zB?tgY31dDt(qtzT=b&oy^}Fj(uQnuk;WgCADhGu=D~_a11=XCc=gp1fr225C>W0KZ z6Rm(|a{3F<(vW68w7@X=9qWp~niwyP1-a>q4k4`8{vO@D?Q^}i#n5MX(sK|1q%q;c QLO=%s2m2v%Emfv*Ctw26%K!iX literal 0 HcmV?d00001 diff --git a/t/files/FileKeyBinary.kdb b/t/files/FileKeyBinary.kdb new file mode 100644 index 0000000000000000000000000000000000000000..0ce9f58b74b76be49a54ed772a68864ecef1a433 GIT binary patch literal 636 zcmV-?0)zbn*`k_d`%AS00000200RJ(yze<+XX3b`xXP)!O~o~(c~_Q~H~jC&k5#67 zY^Ll1000020000$99WkGZHVsd<oOc(AuCAH98|~^q5S|%Tx@36!}yM$7Pb!6mDh5& zVc#6#=SL|tBrmVa@Eq#l!l!EHID=78!vFx@?YQ{z7WXD9;Oe)$&nr0&H$B^ZA_kqx zN*1_cBK4rdLMUBpepDRaUo@6}kVBURAB71j%mwId+EL8%zLFgwm)1lt)0-lgsNgR* zo^kDpwhX;5OpbC7XDZ+AMBoetj&cY&PYwj;rhSD#2{8Treu->jFzFdLR%>%qTqiMk zHxf_CY=;TgnJ;8&pQ6~2GFEy`Xr?k#4T-5wTzruVj(KN*y#=)Pr)Q4&Gz^FKD=0As zuclKxf$)_X#5&iM^?;M>X)ocm739N!o-%pjUx%WLkc7*p_4d>kwr|lZ)`I(o8iQ#H zJT7un1}$izDvc21V#i3h6kQ;j?p4iimXaQNw2$fX_b%5ejdwZ2Sd2vklz!6AD&k!a zrX(A)a10ksznzdK3_e~lV=2{NB$$@0zczM8p0Oe-0dBGDqcM|gzgkk145O6TXqbIU z2&s#lP{RbB7^i!EG3UCOc;t8x32ELAl6t3giibSi#G{OH0NGNlhu7ALBpoSe1_A=# zII1Kqb(!lBLM&ubb2?KC8(wBLZT@QKUMr1%)r-X|w{TBi+vbMxw@P@#ndW9@lxG2l zt0P%{KR&o#Yo;>XY~sUPjcZzNx>`9J<AYHa-r)i^kRlN|daN=Ss}u1!^O24xDN%<a W4tXrCuP;77F5;|-?-))~-s<>mU?&j( literal 0 HcmV?d00001 diff --git a/t/files/FileKeyBinary.kdbx b/t/files/FileKeyBinary.kdbx new file mode 100644 index 0000000000000000000000000000000000000000..fb9493f72189fe53e8e0cb0b8df6d27cfe694bfb GIT binary patch literal 1582 zcmV+}2GRKg*`k_f`%AS100IC45CAd3^5(yBLr}h01tDtuTK@wC0096100bZah-eFw z5D_S>-BMPTsph_n((Vg1ymQasR|Am<_WZEf1t0(bdND2c^>EqGSo|d$)iZNtm_V(? zC_xpYp-X=GT)WQ(2mo*w00000000LN0MRs_*``B53xY?dD!_K0W(Xhvu?3<OKcfia z6U;Q$QDJ3dgJaZMOrIUiL7b6N2j>h*2_OKb@e!5`V*)2jf&Ih0Lt?{-=u3?jcYquK zr+HhzOjt1r1ONg60000401XNa3IWhrrjco)o4#u-EdP>D+7fdm^*&mlO=m-F_ORlP zvt(b7&bU?SiiK{i)<7uDv&ayD_7xG^NoBm9uANPq<cJEtk@yl(dW#@BccK4r{+d<p zR=$YHmM9688he(+A-guq@M;u2*4XG59N4_;J*C}!cGg)X;%STNHnQM}^yv`?j=7sj z5a+cIIs1s}%;K-o_m?Hf`VbQCqm%drK{D24%sb;{8JKk-p=o8chRBPtv;3txWeIqk z%k5Jmm4pYwC1aRT4)9P^XO5Ax-lBzBAei2{=tONh=4^6&uGgbu0&@hC^3u--dVc#X z12RTe`ATgI&?3!CXfX$~@Gb$zIOkCs7oegv_Qw82xPM=Gn&eD<;XteT;AVDqm%t85 zwnXE)(vwv9Uy}440A&5yj(L*3qWe@c!3PfKvs|5E9;aKhH<BgSF^T{0|45pW{N*tG zOtiy2OtG|`RpEE*;}v9dF~VAj(ts(60_q<-cv=4`J{bFjs=KyiBRro75_SB2;*Q zj!4`X@5IX;qx++9<C%4P`wj0jR>xw6gOob+sj;UD`~4GykUH5T(3)N0{3iQDvd~1? z--=ggv4n0o8`^KnRlz{EVQ4LfHk$E<XhkVg@PGW*Nm;w<MjUzu)tb?#b=}HZnS9`) zq}rsV@S?sQO;sy(d7ialT_#q-HxcIr&H3e%?2fPv6QGyeXoc;<pGNda|LMCol!nzd z197}Rh+gK}=UswW{m`x>p9l8Hw+<khwg-Xg0%uGdz-?3^gBKR{r=Cm1MpcxRS=Wz+ zWVmuyDAG^XLSmp+fnj$-G?j)J;$_-z&(fm}s`|j{685Tu8(49W?+*R_24zC##uHMU zz4Md?${j-RuY#R(uf<rEad9mlCxX6(5L7mMK5rfcoi~F7C1~0uz(RuN7KvnKD9&6b z6b<htOl%mS=4xu*z)ScI7kRD3Tsgs+n_{1Sk4Ysu7Swa+C4j}(O8tvwL0$U#!9L!N z?GzaJp~xf27`6ZD?=%fGf>5>9&^>)fOMiF1ykEVK+c$<i)qy4MD5$peLK1^?E_kyV z{q_=rG=fo>Vm$9pD25ks>tbLt`qo1PjkN;D74UcKJ(V8|n$I}%wh7VXiYzmWbH5!% zC{#^RU)y?N@MyfOe}d<<(ui{wsq+qV@Sl#o?$gSkH+`l<n#+C;X3S}<)5t9B?cupi zs`B3N#c*B|M~9B0(F0NFo)~_JI?}b}T_v;}D#T!r1L;em#$GH%0+`bo^vRL$X`t|i z-tljlaz$i-;zaED4`u$qcTgc3^sb)RbOCvj?Kc0Fb}JAO)W3r_K`6W4DQGaj>w)F$ z727U87(saaSt?IC5CAFhZq9>ANO2Tc(2q^-2#h+L>M8)ZPLYufbh70(qrReWhGUWu zNN0K&`IP3tc-0orf)>s4pLz*wC)ND@X&esX))CDyDUJ?@aUZcqX{;M0&Z?bzFDJIg zIqTR;D}@9iagQ+D_toN!&(H06RMJY)M;arCkbo_d$2&MoPDW~p)+Tc!?OT#5?7k1O zc}gbgv2!MBK#pwLuL`{!d=+onm8c-_<tx>hWnMup*81gn^Q3YqkOFjKOQc8T+pbWr z#x-qD`_`1_2}3VXP&(@u*oOiQVAMF<u5_>AeE5ut1YAdHhW{jt%<yQYlh1NpVL3h} zHyg?gAFCK$*Cf@MkU=$elPgm5`AMDTG_Km$R0)f6HKpz18Gfq<p%_42wIU`D9_w8` g8*dB5&Q=yRy`yB5xZ0|Gb#g<q=aHUhV|C$z86IK=jsO4v literal 0 HcmV?d00001 diff --git a/t/files/FileKeyBinary.key b/t/files/FileKeyBinary.key new file mode 100644 index 0000000..bc9591b --- /dev/null +++ b/t/files/FileKeyBinary.key @@ -0,0 +1 @@ +  !"#$%&'()012 \ No newline at end of file diff --git a/t/files/FileKeyHashed.kdb b/t/files/FileKeyHashed.kdb new file mode 100644 index 0000000000000000000000000000000000000000..8ef734720375daa95b9f7e0d05201b0ce84b1cbc GIT binary patch literal 636 zcmV-?0)zbn*`k_d`%AS00000200RIH)9)iVH|DpPi8Kk`R@DE+-QF*{ORdlwD*w`4 zi49=^0000200016p*!oHOpa-a)HLivK%%w*a8Y2!0*aCEr%!bKvLS*L4LeBIU?n+K z69KNhR&(fnJjHF0Q~ktZ9ba+D43Fwi!vFx(bR0&(i#`V~MOU-G#sg?Ob}d9v6ljw2 zJ1<q9%67j34n=~U`-^*H#wINYLnGQi+l_%3-jdwaz_d8jU`2a61LidST*b9?|L?er z@8%N$O7H6X(rYyu=2{>i#fcs==^Ts_h|^(m6v;ckA?Iw%;-t!H`tno=TF5d!6o;<_ z*Q$MxAyS=duWiD~{zrWkVwU@y#qPvs6^zHlPMq8!Jzg{nkdEbc`YY-+Nkybi-f!I4 z7~@=CQwXsv5zRHY^z0eWVDlhlR0L?6c~7ok1#t2UP?Y?Qkd66g^_f1j>&|H7^bD?S zIHgNt77jf+fkX4sk8T66g_*6!`<&gE%_~~cGH@A`R#r0oL+ozwrIZlt!%)3*ffibS zEkE_v#--h=x#&6h=4Z-85#k(99le5ODe)2%MeD><=0X%drA;gv$k)!J=bIU2jZ+wv zZVBC(1J2Yf8NEFMH_w9Q^tEMhQzqm2eY>gty$Fim8b!vNY;w1N`A_W3Kjug#?JcvR zx?B4U6*AWcvTPagVq<3OTeH$XG86KBHfAcEE9edk%y<X+C_6f?ygpYxSeF5KYE$5w z!=k4ipb%Nr&hVFE1KXSJ&#K)be7(P(^=~h?&1cGM$1q|{-veBqIJJ@{G1VtyU1rAn W#usuSFbTnH_4M~FKZta->_ZdkNHqxn literal 0 HcmV?d00001 diff --git a/t/files/FileKeyHashed.kdbx b/t/files/FileKeyHashed.kdbx new file mode 100644 index 0000000000000000000000000000000000000000..dd60ddcc9d79a3a7e89f63f09eed61b5e6608f5b GIT binary patch literal 1582 zcmV+}2GRKg*`k_f`%AS100IC45CAd3^5(yBLr}h01tDtuTK@wC0096100bZaVX;_W zVkuMsR?$$$02@Y9p;U9rMatru^(OZ^hB1so1t0)-@>#O7GS@|*HhjYspQcr_haKjf z5axBZ_F@U|Gxt6Q2mo*w00000000LN03|D}X`816uz3ZCa!dUc5eOgvDRyt|BE`!( z707FPh&f74&w#~$5$fL5*{06bB#iZq2_OI;_&0&xRr*iGl%`9nxPfEPQQ#iXPred= z9E`!Qwl1{_1ONg60000401XNa3X%kr>8>%TmOtv0e>RAwuMC{f^h=(vtLB-ZKt1vI z>1bPUwZjDjZqwDydMjI~sVq0tzu}$>$6wO4*s(2KOofPg+uD;3Tn<SyiIv=#J2~E+ z%R{`pUme}0#4NbcF->?FlHEIwcpt*ps9pSQjwm6m>Mo7qCrBNjMCcMrV|54X3D_If zim1pJYRU+<2FC|aGDNN5CABg`mhR0P?F9V;m9l3+Fz_2xr_@aR5D=y2^tQCsR0$s^ zduAu*8v-z64N4L>TQ0htAKh*vxQI~i96Q7Wm8W3Dv{z5&1j8QSmLRg_x|aOc9;OR_ zLyWP^$$vrt;B9j;zC0Ctk7K;$r(4cCfu=q}x1Vy<VkZkOZ>`x%#Fp%L<NJbS79dsp z1}l4_WTI-JhWe3|kP#~meM>CQNn{5NhXA3I5`y+pX&saovb{i6m^<i_mjrtL#C&W? zBQv=-Gs7ixLf8M&>iom2T)J!VkE@f#fP%MqHIu?%XY*=bzFhD7+L&)6P9DAQ%~L@~ z_?!c5!<xUayLdWGkE4z|ATd+knVVV3G-zN!zLTEww>y#^*!~cgqnf%VGb6DAJ=kp& zGQ>U~$`c|~&}iUSbs~(F5Z03-Exj<0dYcCJUaQ0=2ZpeTKq2MyYsQvDoSQ6}%lg0O ze^B*YdXp7_5%88fT1kAcB}vDa;5d#n7t+_#ZD;n@M<iO=GMs4le)7?aAoE50aO>o_ z*fcUXoF@641U=?-rLg&!T(g6Nt5SsF&_HP-Bj~Q$uN<Zu?;pX`3Z>D3-|M3;xNOnx z9yt|WPpR-wCVyQ@L@u<Y`=!K*bIpvjSN!2pv$tI%=L5138PHayh62(;6+>t4=5LG| zoJ?>3ex@>{wruEldSOV1!>|MT;on9>3)zu7$^qvO#95iM3BXfeNS{i_o}>!Y%*;!d zI?h5n9(fI&+$U!~v8gO%uJyg#RB))dcqW2LAa+~cMEOC}kbIEy!W1W8Wt>$rPMEgw zE{Eb2cN={zs2pLoSLAQ6lJUzG?(@``8i|s-1a@#a&bUBZ(~|$LmD#_BkzN7Z2jMVB zG5zx&R;S6BLv2Cv%n-sxhmE+Fs36PrE@mzjP4ChDNjv-CSBul?9A_8$B7&>2f%Ea3 zso~Yp<hx6+AM>wHRE5o#xF&K|zM}$O9{9)T*4jt*AO*dX&hthaql?_cw_<$j9G-o? zkq1h{rwJQ%y=v`+azYI=X_j;Nus=G_tgtE~;<kKX>g#~ox#{Xx3+A4<lY*1fGD33u zND71ZAR;pib(SHyQwG$k$aFqI%tmF=RR$`@&efKxC{sF4cz9Ua<#|_aAz)O2s{#Sz zRTvd(0J1B0BjpV`fW5CL_Qr7%w@eBx?D2cyM_*dxdD6OXYx-i0_zHV<J>`$R;W8c2 z;S&=;SVF}gtzCQ+dUiUdAG>YUAF?-J_{_^AwX_J0z)W-0v9axA=Vy%!IjedKkGyn+ zEohspq`Dz^>4!tJ0NWDQZ(&liybAjWVBy7GFN&A5xs-JAtg!UiO~iCn%&D1lQjmGN zFKbGt%Y{tGY;GFm-u(kYkKNGADL*<$ZSU>&+9rK}W*8`=L`WDm&x?M_aeX%w0MFI$ zp3{$20;WYK=#i_RUs+pdu}8svpFPXw9BE`*0S7F`MHvjq3BcQrTs=uo%+fwg7S)oo z-IWLYyP{8Wc%ZO;l-s?RHy|-;+f2$ZWxn+@0Yf)*J2T~213JwB<dka%buHfu*SKRT gF#bQVt=V?B`@a?#y(JA0g}tSpm;05zG(=_N5(2^j+W-In literal 0 HcmV?d00001 diff --git a/t/files/FileKeyHashed.key b/t/files/FileKeyHashed.key new file mode 100644 index 0000000000000000000000000000000000000000..33f4a9fc7e70e5fd47c26ad99b849fcd11f3c404 GIT binary patch literal 1696 zcmcIl`#aMM82?&m3f)vfB06+dnvhHG$7N_MO$@1t5?d2v2V*0JPB}_0<z6bKCAT$W zVb8)rE;aY-<W^>en#&C5+y8LR`#kUadEWPj_j%sWd%JrM<*2YtWg7qh3Qh>S^B^XG zY6F!8ty0=hE(p>@TPHUtDA7>=B+!?;iSQ%>fa1qrDwPgXR0RN8TPHgkw}>3U&}9Vr zhT7J7q3Pg7FO9d)`fs=Fw)@^;pDJ?|>b%RnU@~dZ_9#nE>@s2Bg-nwP=h`2ziP&R% z4smC%Z^E8!oPwlXt}m4i6y6z|YM)=b^btiMhXs5X<dYZH>X{3Y_8$`SwY=PEHM?YO zO*=@;d)1wrXLrj#)n@N>{y*Tr_Jo&#orXxJu<JFt(@>$hWc<qumnT`F1L{|@hY3xo zM_fwD%LI9OdH)-i-jL>o<dEFbn6;(nG1{&dF32FcJW*7@)0&BdlMrA};ys5#Jb~~V zFd!g}RENXR+_t{>Afky{^wO-S`}EnX*RLlLr`wMJBTS+WVKg1)0gWXvvg53=8D<hK z92<Jac8HGKF9knwB4t@P+R^2fL53!BqD3=%8Tfu%V2Bk->>(pwynUMtU@(|}%F6Up zCu;r_KF-c|0cK}rvL+R&t<LaUYz-I;CKs!hdCxNc1e%MP^DQ15^ED`_XoJg_c+vj? zB4+#aRT9{Xi=hxK8qLKs0$L*AwUqT1I<7a%qhXK{oGv<e@F0yw^QTZOiJ_rYR~okE znS|V8W9Q%DxN?m@raPFyqn1(T>R_qW7xmmdJSu8xPS0UD@Ceb&1$Q^Mo1dTAhnc7y z)78cL_#8ZBMZq(#{hr_9h~!>p3^J*k6bKI_dKFC6r6aaVUBD{s-Mb5LadtK_G)!|d zHZ^VjKwd`G?9+w849=c2qoc`5PaZ$!@pu|<ii=YTN4Uwa16710A8<WJMn-K_q%yBZ z-|FMGgb*!b#6L%4fCCu|SfGIWePX&JKRsL^5J+36G;!M7QIyS%-0|`8pR3VR9y864 zbhstRS<UXR#KHGBqF3fM<JlTo5220@4iT%1S0UKQNTz3IW~L)xPMnelqsn*fl%djn z-Q5jYSt_kYcWa|pZGC#>Vign=HpP+vuf}*+3<d$vN=mMosG*9z>nIjdr3{8~;ArBG zL(tfUhK9giltA-+KmJtpFrlZrdttIQGo;BXa`85uP7kXYt{fDEG_^f3XrjT69@PYT zy1M4)$2hEzaoN#2>LKHd^enrkltaeT*;Z6bM@Pp1+UC2f=E{`1d~lEejJJ0yLVLHz z{+eq1Db*XNRKtCWO88xd$LD5H3{udJ*F&{2rwR9;)NZVa#Z~zJ^5^T`48kNMc=TBB zneM?s7oXn1ivFr7Q4j>{=Qn;icNyQ@f^N<>4z9woArM}k1z9=Sp{=^l&$IaW@W4m) zYv;YZoB@1b;L}lIfUeSErwy^l#WcZJd6v)j^Y&Kd^ZBO1Bj%8TUOw_of_775<EL;8 z4hLJOSmmO0q)Lm5blNKNEIi36`fzx?L=ycY=y6Vtwo{2W<8NT)Ys0-XznADYGrneJ zI}R_ro*MZ;&S*>;ZoH`HF<?|?Kb>WSGtt+#Ni~lV8%mW{RvLa+CB63-wFOYAb&->m zm6Z>)gGX3Syk*ter6m$Yvhon@ynG_(=h`}pvTkOK?|VQJgju|zU1WY?UD*-`P$esD za7Oelu}lK*BePGH6&A*GI2=Ry_`<?M*3B_UoK;Gldk|ug9luq&J|{;FT$%w%q^{CQ zvKe(laye)HQ)>_$QC?Kk#5$s88hTqh@>{27D<d&1=&h{Q(vp4%4v)_vo#`gc^K4p; z;;dt3WMri4e;ozU&u^c#3=sL2G360G6*_#jM)TYp;RnBlPEVf@7Tpqyqri1DQ&XIp znkuK!?mMQaPx5%!p#^swm|7)y5oGI_p59CDcYjycT^)HAE*yAj<2Ru&fJijRJaHM7 z$YI~vzCU!lF_}dYWHCwQ=eeDo)&T9*t0ZqCa#9o}7kipCi&#DFpY6~>mEG4oA=JN} iD*cD96a2q`^(|(F3mFgR#;<@c25_=R*_GI0Z~Y70f;E5u literal 0 HcmV?d00001 diff --git a/t/files/FileKeyHex.kdb b/t/files/FileKeyHex.kdb new file mode 100644 index 0000000000000000000000000000000000000000..ed872c586e8afdaa5c28e994c7875f2d90d19c1b GIT binary patch literal 636 zcmV-?0)zbn*`k_d`%AS00000200RKWuCopgwAr=x1R_{W2FHxw;f|*J;f2`zXn9zs zzmX^b000020002#buZMWp)Qy-?`(L@h!x2Gz9(p?KQbB_+m5q^Qca~f{2M0k1T&tJ zm9D5@$vOO81RHge95UY|kKmFlPfiF>!vFwSQJut*7uf&lv2kc>Uv<K>nx;q*w|CeR z^Y#=c<iqb<dF7uYg5f3G$@61#;(dyGi1_%RSlU61kt++yyygq0Ak-qNHpw(J!IVZF z*yd)JAE#1jUetxrmSDM==sN~od7mTN*36hUsj`hi-=L6((}OX0y+q`snRC&#)f-`Z zf^I2k0Eo->mBPWwIG#8JR4XLoXvhs7q)H=x*tQ@V@SOy{pX*(3oZ`Cyp6_#v8bcLg znK35JCznB8y}d$j;ETCg=0wed?}e2J{06C;%3cvaZ+L82+bw$AIATp3>{TkoRn(%s z`7M5??StCcuU6ywbaDhk`a4R|v2>6W5v>G$E-AzOdJJd+$~SN1PNYS><}Q$~Iz#)0 zUWNY0J~2S}(x%2{ZSQKd0v0NR2Xqa(I&2$*Qws{!DQORSfr501e2ROCwiS}sXXU^F z758@$g6p!=ArOYA{<1sAj2%0VHyA6?7?I1@h0$12?lz_7Tecg`EiHg5Cdmldkl=zg zME}5PuTK%J7n*s6$dKbyaRTu})K0V<nACwp3Br@_q4Ur(l5`~?ID*16Le>oyD7Wuw zCY#%hfE4a*$?CW>@-u~d?Lky+^-(m-zWt;?beRfnyjw*h=wt~(;u(pqXarT4=5y2V W3_(;ct=l?Zdk4@xo-g#QO85H%hBnav literal 0 HcmV?d00001 diff --git a/t/files/FileKeyHex.kdbx b/t/files/FileKeyHex.kdbx new file mode 100644 index 0000000000000000000000000000000000000000..33f1fb1f3b4e89a1cf9b950f912d4ab1fd7137d8 GIT binary patch literal 1614 zcmV-U2C?}A*`k_f`%AS100IC45CAd3^5(yBLr}h01tDtuTK@wC0096100bZa@JdUL zmvTqJwq2fwz4ONAzqN>2P!af?tDd`xtVKo61t0*X9<qw-Y1CP;k4`E#vj&7tBT4xo z)|r3gOCQMO4M%zg2mo*w00000000LN0GO<Tp!1+EoIt{=8mSH_`UoHZ*v^FHq4+TL zS8(?#TlOvAyr?{0J`-K2!}5EF|A>R%2_OK{*y6U6bOvjitBl-UX4<pHRXo>Iqku)> z2dRezA}^f^1ONg60000401XNa3V_P2i~o})1d__EPDW%@@GTuc4lXV@H#ApTZY>R2 zZ_`%Pm0PK)zIUz?x!k=m3cxiTfw4+{!(I_j?nlSaXhbbSD*;WfFXOyH?Ivu_klshc zn@g+L5WW|2!Z3;m3e`O;?K@-2bNxLD9S2zG-1xXn6`Q`RD@JvR(jUC;CAL%<I~Ct} zg6i)6lq~-+gxzCDDr0NaFAmmoR0!T%OBZF;u3Ld<*pkza5}noQrDGUgur`Q)T0^`_ z<xoDJTCyq2wf-+Uj7nR{@w8wz|EQcaZ2z5r@`IxkI{B2}ZahMs?r59;Z`K@&>*q~f zWpZZi)NHR@@AGWn?hQx5yL;xiS!^skL_EdPr$33SPmX1HiHpRelv%)yq~QHHZU`qa z>7LQuzxap1X7pga%-k=j^n$utmLtI7=EsY=o9IfR<TR7aD#B~65{hKd$72zTI4dDv zGI3Rqp7K*MODxV2y<BrBZto!*y=dxLrmtVVN3hHC)?MQ2h0Y6H4(J881gZN+kfozp zwkiSy$DDWB0gk1IQ{pdpbcwl!Eon~H>8b<e6*Ab(!9fs1r}>gol7h{K<Hp`K8jMTn zHCnGB?2?ad1ftk+@RLK=G@NS_cp{Arkp1mz$fd>Mzj4qb7sWsF231(WkDcHFFi%3- zZ-zptelwiJPr?VE5*E)$LVgQ`2^M7rYnQrrekmrZ*r!KiLWcJrKVQiTFKn_1XJB|s z(<BmtQmc<z&Cj~AAShkJ4d9h&K>TUMA#LmRfUCanMy^u(f6vmtvcpHJ<j&g5cI3CW zo}2@VeB;C)3|pmGjU3jkO*>H9HaZ?Zc@)6#7KCaMSlw2XPAUVNE)Juo7yl+=C;=*F zR|^{4Isbd>a|Hn9l5&!E3O}iv3~1rps!RagjF$)LoRsD#>}|v0@lUAHT3hwrs@28< z_PU^U9aJe5{Y`*9)3X&Q=83~s3@R}usjLTNou^H_TZk<icD<MTRnP*gMA9*s9-|DN zaZ(XZoah=T9VSW&aT+)brw3@33(bDGd};qce8$bc%=9`E$(Pv`+6okfZS4c>?k=xe z>Y2pe7fft=xz=FeR)KuXXXH8NwbhYAXvQT266T6LQshvz%Ba*5-*H-gzyYw4Y-0yX z9R*g%G?UvagC*Aj=WK%VTeLzvQ^ufbkezm)@)0ytZ=~T-EoN}>;BtAOxC*{D7t<<* z?OW>`XC|oG2N-<Rmj9!L?NgQ)jVUz<?oLCoNYme*(5<W)+w-zRK=KDnf|(8c8O;~_ zhzSywC-AD2V;|b!cdD-AqV`4y0^SGv05H7z0^9<EZbT`2;l#7oh6v5j>_n3vd`F`f zETUi5+jDV*2?Nf<nHgigyBdOv|A<${NdB%?S_FHW^$V2qWEq_}vlIK$>&17byJ?1n z#)f|W`kbdzq7JJUZjd5AgO9Sh4FJxz|Gj6L@0ZKeY!r}<=cV9t70}T{n}Nd-f+&J! z*A&Tr4cVcV)0zzNREaWY?;vXKJ^}35H#BG1MSEIUwk;bl4JikqxxM?fnM?yP_IiDc z6|X0N&q*fE7*wO?etNuS1OX2Y?L_dr4|XIr2jPjwhT4z9cJ4&I5&1wa4gefg&vCuU z_%t8_hio%@BJAc4?ObXkMyfM|U5}4y!q)m9ZAkE+fy`q1V7KscE+v>M_cm~%ir0_W z^UX{Ia;9NZtDF$tG&WMKX3KV0a?2TU-bO?#j}2l{>?P~tUGXj3(RGT3Mwt$OiCNKa z)7sI$!>1b4wpuA>4O_vKqw!b>rg4}C23<<^v%>RfY^Z|YBog5Kp7WdZGDsJW7iO+t M!svXml68s>HL(K_djJ3c literal 0 HcmV?d00001 diff --git a/t/files/FileKeyHex.key b/t/files/FileKeyHex.key new file mode 100644 index 0000000..1bf8e5d --- /dev/null +++ b/t/files/FileKeyHex.key @@ -0,0 +1 @@ +0123456789abcdeffedcba98765432100123456789abcdeffedcba9876543210 \ No newline at end of file diff --git a/t/files/Format200.kdbx b/t/files/Format200.kdbx new file mode 100644 index 0000000000000000000000000000000000000000..c3b26cdbc58da369d2754aad2cb7882a7da8fadd GIT binary patch literal 2302 zcmV<a2m$v4*`k_f`%AR|00IC45CAd3^5(yBLr}h01tDtuTK@wC0096100bZat04lR z4Jv$lmlrlnc#Rrd5Bg-Rttt_6{;A6=XH7}t1t0)Zf`>upHMM_`*|S^R*7ejvT#_<+ zVl8H~ZIIhj@l4tV2mo*w00000000LN07NTRTEDzLmP?h>H?5f+1PCAij0ab%@_#($ zZeX))rR!7`u|jS}aDVUJ9w=h^dYNMF2_OIzR}|JVZ&e9CqC&PdI+_0-1M47<P1sc( z_k1Uq_mN%-1ONg60000401XNa3TIv^^3R?bUo0QIfdn-|>8CL#K~hZr&Q7}S((g$0 z|L(Ut`6;pR2DYPl097;;#!`cSAni9X;ITvwhvdfFDJ|U9u^Q(Oc^5JCe4DW4Pu0F~ zIw^+E{v1C0YO<2(V!$j@@EfRI@<r`ooBF5*pC6i7$rDJ`b)T(@)T>qM*2#sGy#^TU zXfUFv(-OT}FBOOUs^QsiKJqz;jqy&s<0}wG)DN%ml&krjq{7+6-pX*!Ky3tgo|^-9 ziC6AVxfJtbwHfJL@eRF!A7N}gyRfM(aI2NbMSG=XKbU4TXJp<!JPq|dtLmI&WcLNE z&L3A^18P{bHCW=f#nO^$j%#3p@N6|S@d0J<_wb>9=*+wt0WZVhx;LoV$I!p0foP^9 zrp6Bhh74Jk73o1+0iksh9{WI3o@FRM{_wPx;Zib2wX6vwFgQZtV(IuucjL^u|E`rc z6Zz1E1k@6DMzE#?Ed2gjh-L5f0boGNfrthtJT(VVfmy>tZ;^iZ)bu6m34eTINMPLh z2Ro~*;3o*(I3fN-i$n|Xe8vEDnKS0B=mFzIx_A~jX|fOP{L#V&R6AL^G=O2vQ^@=S zdoS3S&ZcAZx4-2}GZBgVG=(t@_%%@eYN-11f`w+TMiUB@#XWGxxjHFnK1}<eLYTc< zkO$w(x%hUIN{a{6%~s==#JbPByPXOBruK+l?R=iUnoZIX4R5T_F}G2a#chsjL~-^M zm0VIw?{LPwQZ4xS%y;DKNCNT`P;j-MUe-;Su{7Nsk>R^D;%gs6F!1=D!VF!HNa9`> zUTd>!NPBB+opPHc<*<sDrFwZ^PcEJldqd$n#NbmvSB=e~fxwD`;i!1D$sH#m%Ror1 z)+1LQb?WyxK(tPbsUxD^bMKOu9$gv(1k$jS`X-FV!7N{sm03(O<%&%zbUhVr-zC~P z^Yska-E`YK(u2Sotvub4AWNp&;KB{f#D~A?c5N(47zeTyGyhimjJ$=i;pHa(0Z0~( z{MS*Evb>~ZQ4E>~<X=)%<-W$4s$U=U!N)d&zm0OEK)@hfSx=C*xYv+92LQO@1%;8G zy7jl|A+Go^5jAB&CEk)N1pYD|2#%{3e!``!xWDM*aIg6qR|5!x5<12gP<ctRQlVOf zwxMoqcTRfW`f%X|M&&N-17MGkciGw?m%jH6R=|J;M_xa~fY7=g`NGpy6U;Rpiz^fC zVTv{ilQ$X7YaB`w#gh`Uq8mE-7_?sylpm548ASh+1#J*k1ob?*W_xQ<TnfEcA8N{n zg}i?-y~$>7As}Nuz4-pZSA;3j2FxG|Th7gZA-$Ptmm;kpnl#ER*v=40_F;6(S@_hf z2N9T6A%2wU!>kFV-L#-3N$s5HTsv{uGz2*Evdz!w8U>Zb#pbpPL;Gye2aOTK?IHfR zi0#1m{HyJUnwE#A59dc6p#|<_iH`dB1O?q}(hRug0caU3JQ*q0gC`|J>pU5%RY!G4 zukxOViU^x5-|8aRRVF7p34AZ{T#SQE(te3K&`F5zaWdQxVE!DQl)A?JP8`cjnKTMR zC!c_%0Pj6SA9_Z~Gs9fo?D6N5;hCdl7;O4w0}_dBZhesE@c-K{tG}jLXmq#X99HAs z$aZH7Wmrepbf%vV)3AM*ZxS*ytPlROsAY~w)45-^TzhWmB9DQV?pc~^t;-3Z<mV@& zOK>Sc5l^7pi%<<waWJIe%`}4XpZIp43<jlcF2vmpIRgY-yAL;PJ9@*vX>qjotn?xe zPKN;QZ;r3SpRev?qw#Yis`hS`5zkkYt*?79P(b8c+B!2+N1lLr?(aAh8v9jQA5vC! z)hpEtolrrMFtm4vRHdj9#V!es+uls$&(^f0-}7@J$DGU}SIuiLU<0F`XRm_<ndMcy zP`SF^1S9c-?{mQuvyIZ+B1sD+x7qL*e9COQw5ScWati(>4VHLGRTsz>lbCjQMc#v2 zWT>?D$EO3=zvep&ROyEGyjpP#OnpIUslNuchab0u6z%?bRQs+QrKe>0Ttue_$U24F zLg$KeWgU}QjyQi&nvp-(BFvBO!Q1|i_4g|PW7cS%!|xX$seb^I+{K~ZU~7g2Yui}T zGimxn`N9!N5?C`TLIW4Sqo$gidac(-yL7)Kx&%e{*!Lp9=W_<IWo7{p$JrU_J>-+( zVfW;rEk<%Yq?;|b(e2Qa8AqZ^&}C-O+3pmU#`s!xbA3GZ^GA8})a@u2;I+uNgc0`S z=j2d;sx^ReeP_zroBX(dE(!qkJ+Fh-_SjBL{KjLs)@7KK(fr>V-}xrSl;wt7dS?p= zPWvB0J)qN{wJo|T#F+|5-wa6G7-U|>FtJ@)r>kDOceRto@xWR?gO=-bP!hYgFhMj| z+A#ij4wh8N>SA?O-e`xfL(&W9PMzn+M~;Bk`_056h-;<%tI8v7oe{v#Om26|g2f0z zh@L!;kuCh8F9T)ub*)~nMJil13=7`e{UYK2QrKVO#|ks|=e*62OhJm@SUVnA*@e|= zTzIXpf9M#y<GkZa>EWvOA7REC%Dh-4v2ol;vY}YQt#cy90NU;47bhVpz;+GJVLy}t z>7~UAP{JLzY>k`?j$W78K#ymS7MBcmTID+i!W9VYDCZpARU0f)jGAq-b+%OexhK{O zP)>`zG|kLiYLEBoB+&XdrUpk});{Fm?5oR=5tHnl`u3CjI<}XuEfTPe+Y)1WH;=fT Yg2A&`3WQ?A1AFO!o&7-^>ZzDyXeerT5dZ)H literal 0 HcmV?d00001 diff --git a/t/files/Format300.kdbx b/t/files/Format300.kdbx new file mode 100644 index 0000000000000000000000000000000000000000..dc67f35a11ec8caf49583798280aa883657436e2 GIT binary patch literal 2014 zcmV<42O;<a*`k_f`%AR|00RI55CAd3^5(yBLr}h01tDtuTK@wC0096100bZaTA1zY zm^1O8EpX)*ZcP$AMXJne5U;}Ha3XmHb7prS1t0+6|DCOpZviNlZTksBdrRsJ+D*cI zeo!0cN<h6qm!9?p2mo*w00000000LN0F1`S8ZrktP?*N6)(?#2tq33h<_b6h(zIy> z1-ugfD-Lu*>xcmYZ30y#*5~cZ%iux92_OKzziLS_U)2Zw5(D-ERwB;$&PAv~&zhQt zOXV(5u3|3=1ONg60000401XNa3aDDg+Mu|x6!`^D19gacspCG<tWAa3!Dd?_mj{o_ z4gOQ(nJ2t~jnU`oTQ3N+KubY<qFK3CprMOO;)nQm#e6;>X>*uSp^aqgkjZFc;z2yt zX5j=1s^iBr^1g=BWPg)*J7M!yZ<;>+o%T>JlOa1SZR2N8co))zE8<lls!~+zpDVfv zmMm+(HW{aBOsK{^iui7leb-3n;lDyAJGIb%1cjoatZ|p!iB7mJCNUfL&Eb<UC`I0N zTZHkKZo82IZO@@<6Yh~Q+jL1Qs#BSsa~{N+$HBHz?yAe>zl%u-fEq|D#xX*)>Ge~u zASv}B>&@^llF*?Am+-p!T~Nt7s|w(O*19MR*a#C|Cs{g9d{a+iJsll#@Ru+RTsdjf zn`KUC#cg@TAEq9m^w_81OF^&s2@Ib~8_yOI;Y^Ojgq)bAhnD550%}&^$r#G`>LSpe zGc;PpjBvl-g3LW_e`%e0)z0Lm2z7p|YdoW{OB67Ut$eT^*aDKNcfK)`n2CcmV0oQZ z%+p3_Yn#{Hh@??Bme3Mlf|XT)C+DM&6jE#<t^6`Vzg2uzz1X6MIwjFFu98bt@IxTp z$pqFhE89m_lS#lBMePoBW<0D?(K9-tN|Zo{^gd-eyM}RotF1cI$cGOnge$ee2u~b% zC&*zkRS4m}F;VPpN;)*cX+kjB57<H&&xn(Xof!2}o^`|7X1&nhZTMLe#)h$RQw<&Y z-i`O7nAU>QJN2C7-!(kRWN@5dO4!5}AMnNwcxO%F?yMpa4ynXUGa6hGWFA{yC#kX% zv)71BuPn~(qb+6zU6k0uH-p#WfF3Sx$MPqXqEJSiDz9wiEzC%Hqnu8TRg%PXdlR#3 z%Urq+Aez<Bw@iCWpM5r|&83-MBnZoqYNY$C5*wKI-|BjP)|y242`nfz8*t=%vVE&g zTOd2q5Zxj>yAc(68u0?}R6|SlmW&Z*{d1cJm36*500tf(n!p&+!n};8xR?M{e{%fK z8GP5-W8cmHw~wbmkYDH|k|e`U_TjyW#9CmEPMipqF~c-*xwL*Px!u+oA61}`0w!`B z8V_Yq23a5=3{23}Et6r(gC+wz)MnatP`BxABPjHQ4b}vyGz+HXvtiI#LkrzZNQS(b zoICS&dPlfx=W7Csx$4!+yB==5xZ{-AA75j_g-ph5aLeh98{6wBoBOS&A{Zj-ExGkv zqCG-&$zel}AIY4jnIcO_j9q1<aaanf;v|NPGMa1vcQ!G~nc#Gy!X_2e0`U+qm<vp$ z926pLshfi77{OF~zw_46Q(aKC@AJzoEs5F=Ec2lP10eiqAYk?0_SuDyz<`-d1`<8} zcm>T_-Y#DElmJe3%e`iYK%YUmFVrlP;4=?Mj7~T1r88f!B^}U;c0cD+A?MY#8fPJL zr2d!uo=PJ4#9Q)wBE@o6VL2S^Han#0N9e1+9o8T;4cCQ6&hS@Fnz<)+ll8Lmu+Mk3 zC!SZmf5M|9gx^UvA1=4S(Ez1G{x_R3brQ6CaW7dVAc8jW>Xbg2!nvryg5AVQCA-nz z4nRzsV8&J}x-6NN!XuN*lCclSnCA;QlI5WW)mbgV&t&wznG8X@pR)TD=9(}}Os!Cq zqH|;2A$LWMLOlUOv(xkPJ6khNuhj^r(Hvulp3eBQev$kY=zW2XlCT)Ei_`xGbigXp zf|Vbyz#t=~f)1_m!vgGP`9pSQ_Df99EObq;JSU*ZDz8aXQvXE*B2Zghh>5#$Jl<xY zmCUsWAPDWf79zihE8Y<^{pKS}gAojKn}K5yN>(&{4dqm}_#oDPfg+9{jE3cNI@C6_ ztC1@@m>Fa_P8*lH^6;22Kg4V8AsQhRsZ_V9+5yRa|7LVE06Xo*57zQIq+t?+id=g0 zA1(%*cMPBbznOOE?+;(|bSEn~oDIDrONK9X(TmAly2t$Al~qG9eN?6Efc_8erkE_O zMkY%{l)KbJR1zJPGDWGBMc$XWb^(NF^6ONgs(<yoph+M)iH6Z?RW*Bwb9A!w8!!}W z@+|p?vX2kD>4pC}V9zJA_L$^EtTG$S#a!34A>ZNuFsDz=ti$VFZ@$t%-Ua7F?gROE zo6B9|8vsNDhDx`F;aRp=LG^7gkPjf*==&R@0nd<(s%&okUW_4O@4a`TB^}Jmn_JPK zZpH!`gdZo0q$(Ny`e<*nRo&TG3xG_ta4dBDGaq*xmC5<NI`MKlMY(o($&nKs-TWW# zIdNTz$7O*y-@0;p%$3c#`Flgdr3#LL6hOkfjkEAQwhF0x=N1*MMUkro-{$?!GV-4c w!KOmCPsOf~H_@6*(P_O#&=6&j@b%cdvW`7e65x3b{`%vA?2j}2()urz7l5zN5&!@I literal 0 HcmV?d00001 diff --git a/t/files/Format400.kdbx b/t/files/Format400.kdbx new file mode 100644 index 0000000000000000000000000000000000000000..1a877508e838a68870fc8ba6420b0e6b55aead72 GIT binary patch literal 1801 zcmV+k2ln^_*`k_f`%AR|00aO65C8xG)&q(wi*HP|r6e<&G26A80|Wp70096100bZa z002AsdBAy7CEGE7ne=tFS@D(EGicgUEE1q$pu)ND%M%NW000000YU`;001OaRY^n; z0002*V{PAzDMU+=_o<`<;|dG}0RR91Rs;Y5022TJ00jX6002n{000020000000005 z0RR91O$Y!00000G0000000aR5002+~000020000&0RR91Qy>5U09LF9Z7qf>u*D1j z_7plao%BKS=8+32eW;I6!@~mEr2q#E0000pKZj78Z*q{0Xp}Gj1ONa44GIkk(A|W+ z?(w4C8xGa`1D~vE0Is>2-H*l&(4ZVrZRd%*bGLJjo?PbTu0158zkZaan9Ml=_3!<F zxC9+Z5{$NK39cbQ=fW~9zZiCO!fT0Hr*IAK7Mll$UJt|xVF7*#hy?%uoyCpR@sLsZ zbgjjg{qj!d#X8>qI=EUp(86)Bl)HqqwaowA@b;H9Og{7ytKFz7hPjH#4HK`QSqQwU z<9DY<b!c{u329Cp+%|?9pR@oQN<drwIi-JEiqr9f-)ZIjc2($nMLfpWsL!Z}bR-CB z2AvRtxC4LBR1Oz6xf~%caZ%A{f2k^e`t7<L@IW&+|LEb&7=h5K(C8mVMzfv_EnP7$ z%HcC|1XgaS()U;@zpo=s57ZHKHHkON^shG0bQz+d<cVpdgmMjGGwwjbkCnsBa1WR3 zqE_=UWz$)WnQaN+iozkpijDTJ`c#Y=?A<phs&<rN$WDv?-ut$Xq}|)ZFI?A{Jkr31 zIA2&?uNo!USU>O&?^Lo>q3uNhMAc^iZR($z@A<cDBqi<?4MB(@GTcBQl~1uS$`b40 zHLUrEvo34Q3h>ZTWMH3{Jg#^VK8hC3Kjz7ZO~zbjx)`(aL0*K2x~r{FV!qevR=3qX z6;QycGP6WhmBUS%kdz+iHp9=DT`WN8!H-9?B!B&zN8N_e=n^OyRGAtHr&g@vZ|_yu z%zFCg9UR7*{GFN~ur@Z;zI~3CkX7UVUK|$LSZZU7jf3s%I~!}K=m%<|Q>GK-$hRzz zEAfz;xzo?gf~4o9-!*~IVP$Ug@hJ(0HLMI1Y7kza2F9!!?H_Xtc&1|4>KN&;zr|WG zkve*EA+CmsOKnflHj5hO?kAUre)_)CgSvdYx-$&_lQs0<%BrP@_(?hxq}6w;u32;a zaa*cXHV=h?su|2nHJHpFKIbTQH<l;{VpMTG!~^_YaOA^Ze~KF#S$4z$X;7-WQD<f2 zJ~e-M-l#mSsNhs`|Fb{IgPLWd=;nOEV$;T6pN!%3`RPxFW_Feg11CHSTv<@L2Q;62 z8=$R@lMtc9yp8>1`(a!VY-57+N|%u@8=VVmgspcQ@r@IQ`jwn-Zahgw^+(auwgmDM zuuEm^;qFyP^A6n^GDRaKZ>48O(Bt5d_J{5b_P6~tva>QjaOhR%dQijo1#7gv{hZ0I zS>o1g=+gn_WcPArddeiCyS{Krs+A03fjgrxI%sxF5Gypbz-M4Mjhwl@&m)5vx6l`s z__Dcap5oC*o>MwknTZ+qBHve(N0%Ge&ytVuRDmNB{-yzcV!~9S0(ueg3Sr2;07YSc zCcWsX(@fxVg{@W>x~?)2c6q8!w+zdt&ZRL2e5tbNKjqHjLHP-K77?yk=*Z2f2e+w| zYb=U<hpusT82*vDrA^nlVB=(Jnio@RC#JT5bmmnsQGc&Ua_2!)w>1(tbR7iS)NwJK ztA8GJ{_4<>x9dPzpN$xc13a(2T`V^Sjazwc8;C$=GskV#7;1mt-_n>>RNnl?(L(=E zO0~7BeBlb}(SW>~mB!6tnLX>2z8HoLV&`|7jcsm@mbInY^iAL1mEpH<3l7c?%tj2G z<jh8S;Edxrx_9;XLV=)VqkSr`x7WAVqXx;C8a3f*Skhf%@vHqytx-xt5?!Iyut2cx zSE7xlZwt!A!g~xm>i^Z_m_bZ{?mhXA3$%W<(FYy=@$_o49eslC+z$9t%$?RZ2ni+u z{s+ywuTdHA83ti&`1xR?j!j5Ad>GqTNjGORo>Ae=(^drWz^h_)IY-;Ii9nK<AigU* z1>d!3Qz#~>hZeE2&w~|aQ;2#`i~@qnL;Gu&&Tx8O<^y56H%`h*nRRFP*%@Q0CbHs! zZ8GIVEyoYYL7@@68%6m2u*cf2Ovmdr%z+OT_6{rUYk?q+Cf>{MPP%vPZ=7;k(su)O zEo_<24kzHat5>PP+zLbE^eh?4Pe3z2owR|cBd?Cx;|K#ODZg7|Nm~+|)x?Zay*5~$ r`H}nGlUTlv#AmSXdYJo0x{`4F%hdC3e3OW`R%IFyI;%Ph00000Hm_K2 literal 0 HcmV?d00001 diff --git a/t/files/MemoryProtection.kdbx b/t/files/MemoryProtection.kdbx new file mode 100644 index 0000000000000000000000000000000000000000..6510cea8094dc3fe028914f30a85fc79b2789655 GIT binary patch literal 2053 zcmV+g2>SN}*`k_f`%AR|00aO65C8xGF~RcYzi~rQzE}kzYW!ON0|Wp70096100bZa z005^!feFgWDpOWxQnO7+eiqF^tI|T4RA~5nBHXE7dG-eo0002f2_6O=yD_@KZ$od; zG^u+FivR!s00BY;0000aRaHqu5C8xG?_+J>j44D*k@u;j1LFz|1pxp607(b{00031 z00000000F60000@2mk;800004000001OWg508j(~00062002S(0000}AOHXWO$u5E zA|}KcuCjfYm2AprX-&aKk2L<*j=Q16v!R&n1OWg509FJ5000vJ000001ONa44GIkk zuZO7WM+Z&4oFX$?#rT_rMY>L@e7mmMps|9hdjx`D6(5uXDj(z<PsF!f21yaAZYBu{ z3(!?%^5TSX&UrK`_O|4au<_33$<O+gy(PZdmLAmiix7LrnQl6n>+jE=fCc~n|L;m4 z?Pds?jrl~PW+~*%ciJJDwv_b-@Xl$y*{GJ`)?lmjkxKFy=53zx4tUqt6gZ!!W?xMH zejSRx6$5+dk|Iluo%<lZ?p%0OXMax6(D-EzXwRI)+d&^aOZ6zEae6ro=TY9V=$&Nd zLUg_BvAxvp_dwDsbPxoIX_-{fTufGa^Zp?Xhb;;Z9tYQoPg3Yqgq9K-8^2}#BEe$z zwWoA`4_i8459!tB$%=9*a@GEd`JGKHyObGJC!HKV;`v<)9Nl6d(Kg!0&hT4Se>;wt z@pzxqp)sNOUb^TW=&1t;2XD|}YM@n!L(M%%F(XWAK(3}m+)|G*tslWB#BJp>=+H5q zeUz&~U`G+x!zi-O%3E(|7wk9>lGb)PSQoC-R2XQtXK*JK&%`Ch>6vD`dg+v>!oE$4 zY$3J+P7ku8ZR5V*TfCn?1O>34#v?-t;9hb;oWxP(+k`a3<%|Ex4u@^K<Qa@cOX6pI z{O$^|7Dm(A_o+ck$?!1}^gHqSod{+_-q_TD-himKW!f$z<Vs}LvZIS-K$a^2fy6e6 zZNNeK!zr(E5q^5^|N7XYfhYa_1;l^wIgR($XY;l4`~YBdsWmJ1ncr~bNtp_M+74e^ zKQ5D@FU+p^qGe>d=B!e=ha{NZ_hg#$j5m85G8Aml)WrG*>KrYkqwnn%%KD&GKgMF3 zICr~3#T&Z!4;pcu&E;eNjeCU=@8?+@3C22|*7ewpz^gTB?ce`2)1O`85>qD~<d}}; zyof=_GdW6TNfG}ca_vBnK@?*W>(QvoJ_gyGRu+@UA{KtPDQ5k4eIU8FZf^W^t8=u@ zdKS;jlhvt@kqh$EJj5Hh(BOmnr-?J6ME}oBO-oT$RobZC08xXL`S?hW4Bi)n)RV{V zu(zD9xkF<a0@IQFw6Vh^z-{pOT3o`|<?-{NY)oI;PDYtrU?J+$Dk<rqCZ$;yUW1R5 z0nP7lNS9jyq@gw)6D|#+m{j!Y<tCRJYfK%;bM?X5Ybiz3ZF9JO=gnYy9Y*;|{lC-B z&8&6wMHH6z6*#5JuO~NUF-#_W!GIew_FeuMDoUd-LJjnr2<BRTdAJ?Cj@TKsXTP5V zH<P0Ek*Dlc(RPojE3zfZ9LlUzdWzut@fr6f6mPP!4RL$Rv(%39ha?i|oiC@jDTeEJ zrM_)$t21;c^l=i?Twuq}ssz+5(tz@M<D|P3pZBwiQ#0|wc|PAzvM}qOo-PCfx){ds zX=DHDv=Jq!s!HGL5+u?>Nxt@`4Am4$gQInHI-Z7q{V3d4Bb^lWun+7g*ls+9-NZq% zP&pi(kN4#LcC{{Z@d)vskMEWm6y7vE=tjq=f`%4+_pCeDd2!&nSQkPUpPDPI@v2hA z;u^8h28y-O;2ZSiJSc`aDx^5eWsSUhyQ5eb8}HnZTY!3PLH>>^+un2M3MZ)?TRQpS zu#1wJEZC|(g0%r@RL~u+4#gPfgR`41;3ATaUwr5<ZOl-tV<dNRbQHnRc!G4C;f9DJ z*)pN|a(WwmL+jQFVlPl_(;YBa_EtlZpdbmED=EUdw84w@lmZ`IK8f7D$9;}US)48n zFpWu6yC2N#Ku6s<Px<5okPhsAzG`zoxC7&?Qj8c!d`f>xH+>Ib>t-9-6ZoIR=88zx zx+UB6onSl=YkI&xBIZOh89iIJFu;}QeKnBYwErZ=$-6{bX}Wb<nL%T#JIuJ4Y)KZ5 ze!K8<&|c;9o&ehlaE7sZqBOSB23I={4<HJ%q#_w3XuZsIBD{nYpQ`Opu&N~g&J!zW zU|lzZ+Z7xZ+tD*I>yYz3Yl02vqduOj#*b7OwZk^Oka(RoK;fhx5ut%<?V|ajn%uj= zy2kLag7=zKJ4O4*Nb26_I=i*uE-`y%yHGMr*)UZPP*?Gj$1ZVF?jW`s0y!uxR{Ei# zH!V%?ZG~CRxAfWm`S$9tG|ffo%-Hv+Fm<l5LCDm&%pMfuaDJd$Xc#AO85a&VwH}7E z0my>1edVCiE*xXG+t+e7Wvs+MrThlz6gqDpo<n+d-hkCCcWRz3df_qT^o`O~r(zs> zfEHUj!*^!6xa1wX=+nQdb#+&v%;MxgF_$KSJqk8-gn;wGPFO{USpBn^wC+^m09hj) zD{~g@?53-#sx_d?n<-v+bNNZo$9k5!P!u!CVD(62Ocu!Rf^{%e@|k);OST?vni-X* j3Dbm0efaX}Z7LKy5;>m1d5ozWm}_*0qet#x00000MqS*7 literal 0 HcmV?d00001 diff --git a/t/files/NonAscii.kdbx b/t/files/NonAscii.kdbx new file mode 100644 index 0000000000000000000000000000000000000000..06aa5bf2c8bba3faac9c998b2a0e39530be1c083 GIT binary patch literal 2862 zcmV+}3(@og*`k_f`%AR}00RI55CAd3^5(yBLr}h01tDtuTK@wC0000000bZa3+VWa zdlxnjWOf->TSykV1l|Acy-p$mK{51;mY>5-1t0)ytf;M^Rm=3=&LgbGnG7XWhf1Bj z90;g0HWr}=z!usD2mo*w00000000LN0JN@%ZOO`Wyj6w?UV_v0T?ilmTBKe33t)&i zJw6ST>HE&Us|L?{?!q1nSARB9_8J^42_OKFP-qt-Xq#TMZD!j!vQ^8TdPWQr2szW{ zJ-WqxDWFse1ONg60000401XNa3RA_EcxOy-HBh``gQGaeDNalI>+V--8ZS|~LA}Hu zags+?R#d6+&8<Vc5+A08YvxLIJ;4<wY5jKK^1PzNfpQH&1N)nM+|3NXDKN(2#4j*W zEs&*Nyb&L_0n2FD<p(W?5kGyW?kJ0&W8=?Kbr)!t%$NDc4_0clj)=Id6sLl<CRkFx z2eAkjy9*&XlXQ*ocwgly@csdRrr=Arj$9*ALIADl-t-gUSrgisQ88#<5-IFmuodx_ z8)oCfvCWl47YthPGL%0yV5C~ydOoJI<nG5e^BS<!jOJG?hQSqPaLn&0LU_U{y86Tk zfn)z23TvoA7!h_e1StGge$mh*(DR6)Ej{W^(HmItt~@ujrXFS)^bm(B#A)zy*v_)` zO4}|2r^uWsZvH~5poGJfN1kMDaYvpl3O9N`cLg*QdAFG-#a8KS%xhj4(zF7!uMR_b z0Hx%}FPCTvv;qWu!SD+iM5HlGSVo|p5cu7Gc#z8F8x_78zseQIE?c0J=Bz6Ex`|Fl z@L3lF>U(qM+3<$8VPI3RO3DAd$nz2t1qXMPsDhDWk1-d=cxuH3M>}cH&FwMqBwhir z8L*86^+es#-_U}H)c@pYqF0>(g+^>AnH7iMaJXp6Ill!*trcxhfGy;#O`n(e=wyK0 z1wC$Rw=vb5kip@i?t1=p3+}$r{O~|7O<}E}i^0Gg;D%k2Ig33*&*Gk+q)EwJTBYQC zFH=+gJ;sz&ZZAAJSi&Y<sTi)dAlYO43=uW*Ni2vE-pfqyoZ4jZK_%N+NP%=8otz<# z;33d9TtGmD1z5|G=|jJA!-z$(Cn`B*V;E{Rfxy!|NHGwRVXl+H@@O~v<;jFWLalR@ zBX}TFX9Nj!BZsXj&Gx0@afMm;o@09Z$TFBXo#6d(^#Wi$fQz&)GyAuJ5-e-dO>uuE z$nv}Ejmt@v2i1s+-^n_1`e3E-w+<3^Uh7JMTX0MapBeNR@qlKPtNi!H-i(~On(kg< zfec34wY0hA(0TZ94e>=`x_6vlD(VCujmAx>-G#G2+l^qNdD(pNorBs8f6fF^>J&_< z()5!8v0n&E`3!XXzQ?G+ouTjLhh8?ZQ5#x@{sea2+QE`shESd7I2|q6iF{;VS<Fm) zRY;MeTl?>FJHL#W{&5K&sPeqHc6T}(_#?A5Mm&)TS@V##?CE*Wd8jDDOiy<8Y3>Vl zojqMrMjtpD17fTrWTyx_DxE{rIc7b{L<G!T32cMk-dIga7VTutqB#tv1%SnFW;A5& zVE(G?(EXflckT$6Zn3-$tvtNkFd#b<6A9X*kOS&WPWqh@31m!7GCI9|sJgc1h#K7~ zX_ioXmj%Qaho#pyYFWI7mOoVKjW&kmPk}~merv(>#(X1t!9(oSy7kOoy#2Dtn!7FJ z$s7_n%G7%fMznj};^;4}#Z#^oR6Is*>;~8w>_~5{CN@#&SPby&cQ$I97TsPJfSG>( z*>E#-7BHzhY}Fz7+ytt%+Aa0QZ=!Sf9R2EWGdDD@h$$W>VdR1qm`Pd6wIZ@<8g8O< zliQPszrLO}K^I)LCGSSC3#ItCN2_l9{s6*=;;W|-@f2p9D~YZ1F6wnr0qegf{A$Vi zO0$m*Fk~=087j`u<tcXfe_Lc5<A>^8jLc)LK4nZgXGu;97RCuQoaS)Z0}fQmj_~+p z?6UTqk6JXRNKoHEJO_v<nB`uS0-{YW2th8VWLWgg$?>hBTbJL=$%EPOKj$TJl(d4s z4#)!BYFWAqNX3AMX<gdfk~`mt976>W%Pvou%EFmhsCa;sr;;S__$q*~KDW9z3?~Dw z1RTe^&>ngFF?dV%RI{kJ7Zsx^P9MkCR&}yC>&MSObOXmyy9jr&8epJ?P64+bhUlWt zpeAX6c7hF)=94ft`OGI6<P49uyDu{{*D>6%BxDog+-7UnVPg0#ynr-%X*MozmmuHh zdTUv!SiN3uj}%WjYZyy*(B}!_N~ZCO%<>L}Iv`Y?%-Up9=-b@5K2CxzSsA~npv2tE z1BZ|x^h;^QJ`)L>qD;b=9_lgk=kmy{s7Ilfbjx5VpBmWvKeeOyy4rYh*aN_ez?WfL zaEk@#fmZM+^|>*fDxUvB5hfCX%n5Ju;~Re2urAei3>32Mc74m?;=GL$%v&*$s*30^ zWNC(ozEgR1^QFCq#3s=z*>THaS%(!lOZkdb1;hf2Ed_b3;Tezcedq`+G)!ra#NJhk zeO$~ng1m7H^OaSP-^B!Yt9pId-e0_lh?N5;?!aMJPGhDP``0^bB0qbEAYo81Tof#i zVg=3S*QwQ;hDE1o%)0U(`gB_nsp!+XYI*0lj9adeW!RZ>ET1<hcCd>K14&%)PgwQD zJ4Yxs$5T2FTy_Zxmi&hi!~RO-p@WD2HGADGDuJmD@v(*~Kf1JaL2!Q5Li{_rkc|rZ zuv9ejhoC3ZyAZy-q(qeb@)y(S?g3P2gPEihn%8Kn#b?y=l5#fLWfj@OXg)nd)#xPq z1;0hapkyctAH-s<O?<oweOChBhM->pGm8BXMwGuC!NqI751@<Jf8O_n?6dkaxTwDI z4apikJr`!jOXRJ)MsKsvqA9k#2}$R_FSztAiJNRhG=eJ9vDA6U#q+itcJ?p`0P#Lj zA;d(<OwhPj`qhGXeLe?@Y;U3o4otaPt-f7^A|w}PFG6Zi7^1y89v(_6bYVltSVzrD z_9lmNHZ^v~{N0_Ki;N^O06R~-Cs_m`CSsbd!*I<PB>p>Vn9M6y0U}m^qi^E;#%nXf z+c+D8IsMt-i;rRgZe34q`<3qnyj=sxrVrmWBAJ$AytmRrVEGp{DH2^p`pA*Z5@uH; zj#cNN)3?lAk~I4OfT>A8Jq;(^5XdgMaOF#u;}8#tm=28TAg4OWPRtY7Iw1(A#Ou<j zCJW_@D|fQ_U>*T)kC|r>F#Uixxi=Bm0|bdn3`9ex=PKa5&k<L`4~3i|Y({O%0pJlp zSq2_e*3J2`OHAZd(EfBp-v-J}+dS{^n+uvWWgB~kBe}bf_*~ETj$|UeNp}*q6C2hM z^poB#*vi>bhSxJ>$GGJ@BP4Jd`ee>neVwz%j~T;6xKJbU@qAB=BC}*B?ixni?_~=6 z5#yBJYVi258{E=WhgY{?qnH9vQq+@VsewG>7@P^(C}L$iZXhJ=`uH?hpP`bs@us2F z$psmYISL|g`0dB;2%8#h+2H)hdArjf&j65|Uc{#~Iufsa;>}lf+1S7t?#5H8E2Gcu z61^%RVtbikdtEnLiGI>(C5_-<R1x{UVQ6ry@C-^VkBJjCtM|ykr^(?)C<48<c+BW^ z{Ro69lN}9Qgv|pS?ln)Xl22x<RqPgByks$jm@p_-EAQ-VaQU=AMrbMfyZLvrEk*83 zOIq{NqHkW0P%TY7<cFECCJA1iBee!+X9`$?(sO~zTh75ERA>Snf~V>{z#dzk9vr}! MFr~%@7;}gH890n>G5`Po literal 0 HcmV?d00001 diff --git a/t/files/ProtectedStrings.kdbx b/t/files/ProtectedStrings.kdbx new file mode 100644 index 0000000000000000000000000000000000000000..bb50c03fbfe9afbc99e889c1abc87cec00ed1982 GIT binary patch literal 1998 zcmV;<2Ql~q*`k_f`%AR}00RI55CAd3^5(yBLr}h01tDtuTK@wC0096100bZa?HW8W z$<WOdgw?1WE2=folz2b!?Z{Tr5ZTls`rL?{1t0)<sn^PFS2#lHyYwSeBW*hPYcZg9 z@I|G>)wRptrHMrb2mo*w00000000LN01r2L?k10oq~XfXTBdFDsR$qdB~9B}<q}l$ zuNU-&>f8+j@u=|3i>sd#LaJ!SqbN5E2_OJOBj2zr;4Z$(!cN|Ko4xR;e7fc;F7U3J zkh4C+2T}P71ONg60000401XNa3X1r!===FJTxp!&k3Wfn0+Q+shctKo>HQpG{b7WK zy;;W$lxe_X3(e`JXUQ!XQy*<tdoaQg4h!+x4T?u+!OCTeq;bJJGzVGB=0Eb>K?3XX zZvwgJEmch2fnK@E9kNNs6@5N#0d{WTUu=wpY`Dw_eAf?z3H){+0i-FD6>?D)J_w6L zG@5R;K9@J;&a@+NT(Y%I6_c6yEk%<HL{RIV3BxAk!f_>)BOa6@hGyB^;Ib&)aJ1-! z9%yr2S$NoNM*UReixt=`BhKuSb?8-txq7wuPgO)2MA)d!7Jm;;x;f2JOOG~m3KF<@ zwpXQB(Q#Z|vUpcq2&H&#C<&D~{VDN_Uh8}CXdZFpEK!3;l;f!)capTp#)#*BLZ~+g zf-`Rkr@@mA3=)O1YN6AGO~DSMSy26{TVfAW5FS2k=(f~eCP76X;l1nqaa>f;ff6y8 zP0#BgFik4FN!VHz*|!&D&{$Y#Q&mIoe&huK0jkw<#fMW+)?(s%cG^-|;6CsRl4=;5 z+xa%1k*X&97GyIUT@aV-ga<4KVU?P<Wnbtl7f4n=Ev$v>?t(ll%;V4q0g9fuk-hH@ z(t6p-Bpa4BjLo%B-)I~7u=$~`d~5kueDJVq&F_bA%o7^$ytK@gc%!2vL}Lh734ipN zEw8~FuBkGg`v}+c|61JHF-i~&$MsrT3CXx}%gZ5ja5wH#@=Rhts5fgZIFZazJEO`; zy+!~jpqbkg1E6WjLU)z!g=SYg>loEchY4x*DYyW?G+8sA>VLr883kKwJ>+2(4-wcF z(!JQ4TM35jR{um$Oix|f7>G&AL;TAuGIy2%WKAOYC97gBYh4goYq6)ySHQ+!8?^{^ zN6LeIkul6nPqy+(pzzSS4gAUR&fX5ySWyckfTFZ6Kv!ReR?<fH19(7pUvG^!I&}Fe z`Q5p-5gUWI?qWjKz&$VVB~GxY4_b*XyXdZfk6r)Jn3(Pr%p#B-%?**~X0O`Hn^n)2 z-JWV{J=}kGw*nj*lL2}^v=U_}%<rL(5xc<~-k&;J{{_F&xm;a3l(_i){8I+K@8Dd7 zcZ-^lJ;B8gK6|u($L*sBOTcFXT<u`~p&6I;(B-0`I6ti(SN?XDg(p^Blb{=-1GlOG z;m8`>X~V0dKl`@@GdUpDx(+$xo=u+?#C;e1^+(DmFVmQUGI6k@83|Rt<}~m~(@8qv z^IMQN>v?8CWyOf{Dn<ynyi#o2Gw;kou%HbI(*JzU^%jj2HugY(wAEO(d}S7g5+xlE zA_RguaCq;*6EAyk3>P&&f1?j-P{27GbH{+6&8-jAO}*-9>PrngDc-(eUm%Mm6PS}7 zg~3s){@#tykWI*~ZoDbX3quZArJkm(bpiMXS<`qFOUOj=mn>$P&jh_)itZ!VfR!0Z za7@A;(=Xp!1aAlbTWDgrijxxL1+*^v#bVcqz(>wY+f<iSW;SdZu<)&rF|di3tU$da zoMO`~>}DwK!Sl1OaJ|K>qVv))mcU7KMGpi121JAvGbrbE9Alv-7a46C62k=RE~Cvw zyj?pc&@~*8Z3&TX$Co7kDCWD6lZuA2-bHB~zqhQ(L<F$bk00cjS7oSK%HHAtF0})2 zQ2LDNN3_h1Uv1WPO0G70y93xNje$yn4x7OXdfKJ5GM{&AN`M&ebKy=V5T8_Cz5+I@ zfKdUIAfc>=Y$K+Y*i1bw^3uP2-YHz>A<QC~5T|0dL-d&<?T(p<h=@^gqAV~&G)fnx zr|t@=SAhk7WTSXO?QEt+=$x<zKuDbS%Z8FRhtjWomd+&MaQbM7R<!(8_#kR2>I89x z*6CReAqUfrljkIt?VSW$1<Lo?mngl4`)kgm*Bm0N1@}DLV&yg?nWE@*o!o@#%3RRf zGYK>_N%(L0-mD1KK*7dUBu76x<ZFM2_TK9w?u0VM{Vgg-9tsmqk92)rJv^yD|3V_K zUSD{}31(|vC;#`!JPE|F4EwH2g8NwhF!4pIG>_Hd7~ax@h|BKRnZYJHG!_o}eo$(| zpGa<!mZDCBiiuXa?ez#C7g@_)tIl16IMnv{5FS}za7i84!NLeFr;l1YW{cKvH5M}} zk2xh4k%fo^y_V7c?yS*{7Vn=p%3NM~n75OJWJ%SiocuKjyk@iM!R}f8!L|y9yew|w z@SAzR_7ZYqyw8Q}U$^;FBubeb+thd-tICjhEu?_>=5%(IE$OmgIkjoj6KJPDxq}1j zqY@|yuxt4aVmid$h|B-ASvWZ1<T7ENhW_>Xg+-_C_QAoSi}A<<ditSl$I&x3z#5Kd g<)LDaY;%bsFBL$XK2pPJEhLJMz>G&=vDRx<0v$oiJpcdz literal 0 HcmV?d00001 diff --git a/t/files/Twofish.kdb b/t/files/Twofish.kdb new file mode 100644 index 0000000000000000000000000000000000000000..eb4ae6dc5af9bd148418e987355260b409668a37 GIT binary patch literal 620 zcmV-y0+am%*`k_d`%AS60000200RK=bMB}ca~Zi4rPeeQ$NYp~>QG<2?bXI1ja##Q z=Q?Wv000020001Oy6@hU4O5=-`lEc{m#D4}4L|gS^5r<+8VL><7)r4qL>eqX;Zuu1 z;E?CA+;3ch^Go;hO6-2fQq|B~mlK2#CjbC*CyC`nJc7h+Ini{=19b?+6~-ic4wz|W zrYF69(rOmnwb~)Vm?o?1eaX^U_B*!qoWs9)goUWe!&Z%67a*$c&bjKj01eWLuXKb{ zs<$4_9a;DS+`psl4+AQuvkmZ0+U2`Roz<TDrXSdNIz-BV7!gXWep-okEy-HpLwHXs zRtAF}z1@N=QH4X=YdS{IExi;iWQh2SL?T5i^Z3eV;Yvv8Ued<639YC)dFAM}4X}dm zFd)nodb_~J1_%Thj&+!G+Pbj6=OSjHh^XfBm}-j8p?wa?zd?#+XAB-fTKQf=)Y5sS zaeLNCW2Z|{#C6b;T`FP=3iuiBKJ#jbD0o#94fNt;_FV%qd(Wk|Iftw%oBc+DTzGmz z{fm%;vY8GogL_a)KeN&ZOql)>Y0yQ&`t;Te#T47{R}K-Yq6deFpxEPVwvAg76^EH8 z3fzIFP04vWzyiyr5E(nMCxze?DN!mS+JBY~NuZ#h1#>OS1@9s^CuJ>j`MoGouPmAK zDn^+;R@^k7ww5^g4vwUQ`rTH>2k)XO6zP+o@VU~IJ0YR@-E!iNdH79V-x@+7?CFIH z#v8VxQY4{Uiz@^FeXE}n{XIVDb4>jND5$#px1YG{lr7>P2v0*11G*A|9ChYj`qiB; GU}zDBlPvcD literal 0 HcmV?d00001 diff --git a/t/files/basic.kdb b/t/files/basic.kdb new file mode 100644 index 0000000000000000000000000000000000000000..16968bafa995144a3d842ce26483f6e9c39a444c GIT binary patch literal 2476 zcmV;d2~+k1*`k_d`%AS00000200RJudhV{^D+;4+b29WNAvcbw>~Zo7r|YMZA)53| zYRz{B000070001BRRwNM>PDNMAV-T?^%(I9`YF*RSo6gB<1O^N_BhO!v<hCB0>L^V zX7t{vzoA<LV9ZiS;|^8Z#bs18I-sw~0ssKGftxl#ZO7>IlG_xFP6^3TGT42wnt{5> zNuA7WUr&ekrFx9m$Yb-)WTL8qVR$AXrTV7(@Wh79LT$T>NH!4X7KgjvFi~HxVuDrE zZJkU#yF>{trk~G3{KQ0p6>6~u&j;M7?Tg9n-N@@o$tP!D>o^amUWhAV=Oi_S5ra^u z9;?y<DSwh@Q3jI`)DP>pKntf}BW5^b5^4tVv$g0q4aQY&53I+q9}fcep6^;oPDb_T zi@cj|+MO<;tP~M$XyLZ@*CE+;8vLfT!}$6k0D2ugCXF=C=hmIpas|(4sfri6IB<2P zj^Jmq#3m}W#EprTRxO!qO|T16sGs=c6RK#cY;)&kA0HnxEWigOMR@9_cT)c`fMmi4 z-eE9^!w>npS%!D}W()x>r;~a{{w0c@XK~)Amm562?oaq4kpt6k4W|p7-0~_>3s0rA z*Udq|MEQ5Q@f;eNIV8I|s60Wy*n{WOSf*=ABWd<lQSL(vH&Bb)*)>?|6U>WqJxsy_ zim=+%5H8_)MHY7xf<k!b^|(7h0U$Lb_Tnp|w9zTB?*wxXFLAnwpBgjtnde^D3Wz?j zzaSotMS1NB%Tg8S02I46!7?V)S|7f8hzEHL?(MG6`2uh+`!||GGEeL1yH!}$Qo{?| zIzKL-JAXYp@!1YhRALQ<`4n!krvOK)gAk><PeA+F42YS!l_em`@j3pTJ-ZY{qJWZZ zYgo7(`kSXBK;@3^xmD`wPkmcu^xj6ikC)q7dZnByM+hY!V#93OZRv1hnSF2Stq!^~ z=WA6k+$ZNZMIvN6e<|3BW&}Ukwe0UqwY$Pefb$!E&Voy20cO&7SR1B~gh1YLWe5u0 z4f82EaCl|G;ovAn;7>>|hAhRipv)L=@Z(FtvOJK~_<bttc}_C~-$CSO5+5;`glTvp zu99uDb=kj~x*)3fR*yr9<%(SoAL?qut5`0cuNweiOc&b-`33}KDnuFfv((uR-|?q{ z$n*mrTE&A1t;UX*vPHZ_2AK_0HFaA`aCt7}q>&-{v(;nJ<B1KDas#RyGgJxxd>`wT zcx(iG3p+l~`j;Qgn?TN+I@#yr8wYc4sSrg%5-;_^<f9GNp3Z%WzcfpFzSVOM+bV?Q z7;i&l(>nQWOXvPE-3Ae~Y$-Bjs)`-Lh6)=f`3hr?4N=Vzy7(P!`GnYvNc;oRr6Ex% z3Ur`OtSx6ur^Tl;^>&RV>d(m+{YXeUY`{%|;O7*zDK+1t6w+&xZt8sx<)VMZ&iYK= zV7=SOoxtS2f=2Uwy$M=*#hlmvQL;+s-nVrFY%JLAh%H<5W$=93#%OXQYtj3SwY z#9L;4=gj@x9_m@M1IFecjyp)njpP8M9kdqH5q_TMLu!ZGs3sypfoQc?5~}e6CP-S9 z;yJETOB?{&Sc_!PnYxaY(A)f3l%(Fl-!ndB&MWcI0=oK4(0%z`yy7dU;st30yzm^s zFYDp!_BZO$7FMrn0TME!2EE4Pl&wtTV)1SRIS-R3GRwF!(zwD7<28HOEVfr=uiS&0 zLtup6(<H=PR=8DQV(PP>V9{uzrPnQ6u87>g&jnAIzS|4(OvzkMB9VPZ4|{elN459f zU#h<tX#7X=Sy@9=Hye9nFK!dUJy8s+3JJI?Fe-d$`g#!`*KgSae&R`&+0q)+ChsmO zpgGv**DrU|O8a!*TRt<-*t(aGLgnF=<9C=h)unBX@k4Q;nmDyo4-F}Lhh%v4*0zRf z;Mv)#N|c}_`V@MW)NLvl_q-q*>}F5U*5td>QF{DBz0@~f-1=N^5qFftvu%b@l#gMP zZZMB#O8|&>>;3S#=xIe9jalwov`8nLg8gvzMkq(n>zsE;P1u<-gm798sCmeC>d>5D zlm@_;YaPb}^owJXcl$BOmAZ8ENXXT@=pDK#sZsc-)*+~=A$-JofsN3+tJ^u_w8j6b z$OdvQn+`mXKVSAEZq!=mvL*Uhw7#ypYBEq7nWPItGv}z9Bxl$%$K{!KB@OoetC;Kq z{G8)YxM!(9x0r0<_bSo}IG!@WnNkcQ9wlx8_bvj<W;FPsHt`?FXb0#}fu$zwQPHM2 zKse{L;#*qg?*T_#DM5-jIVVoqwm9IENq<A-!JoLaClU|%pNDn?Yf{kqqt1mUM8GVw zl#=_OUL*t|#N1+C?g@J+<Vr(QsY_so|3O!ZzR0>;giebD6_RJ!@940XkCE?h6%(_x z<*QU@N01|+S(i)in7SQxfv@OGs4~;3&G6NJzx$hqRcCcJM(`kQ@}O6F7u)g|bya!r zs3*ug73B%gb~>Zx8aWhQ%PwCU7yFXF-zdj?yOlOF{_PGa&NZE6;TNo_APxpwiX(vN z-PbC6Zd_x_&FbdUULUHP)%3F!LLTfVjr0nf>{}DmbB-0LxFUT6yRbX0xw#|6Z{GdB zkW=F$m*<Sr@{1xkesJhe*%8&V0afj(x0w@`lduWCoc$ceX*{>apxJY(ji|7ZP)Tes zTSH+s94lYho;5u-9s6#SIm_O=Vm?;WG3W3dx@}R~>JCfijIA`f%FUmg8u80WgY_hO zncpOx9=zAxSYHxmyz_vVj~Av}4^F!2Ki@)EhccJ<Zt2)I;dO5Z65IDr*ihFJRIn;I z{aRTHqfVg-2JEZ<FblhlENuIz893dn<1@M!b&dh@p#yp47<>`yiP1MuI*D{!R4@Jc zuB6Cv@F&rC+8cPYdIQPCzc)W-ClG;j>W`LT`)t)ZmWw*OB&7YWkwb>zesJ=bTRU1t ze%?wlL19z;D(-btl|k2ce+Xu!_($*aE?X$}A<y|C#%?9+cXCvDAP*jIlXydcR|EX% zEgWn+aPemHkm>Qep6otAmJ8SI9Va?ST(KuK3BgO8M=Fv)|F-xEa!-}KEl*ucIBI+2 z8AhOTOibVKywv8ICAgmh2WN?+bympwNAn^<CpKcj$>17z;h|*}a@#+P#%W2uaY9OB zn~}_yMQS+_z4#eHFab9Y(CQGHG*up;2$Xs20$o`aeZ)FINUx9?-T<xn6DDX~k-Hgy qNxsrM3a@hrJU&!=Ft@8Kq{^WDDpv*ia6GA!qlxwsgSP);!vc{7*3P#8 literal 0 HcmV?d00001 diff --git a/t/files/bin/ykchalresp b/t/files/bin/ykchalresp new file mode 100755 index 0000000..c94a3d5 --- /dev/null +++ b/t/files/bin/ykchalresp @@ -0,0 +1,55 @@ +#!/usr/bin/env perl + +# This is a fake ykchalresp program that provides canned responses, for testing. + +use warnings; +use strict; + +use Getopt::Std; + +my %opts; +getopts('12HNn:i:', \%opts); + +my ($device, $hmac, $nonblocking, $in) = @opts{qw(n H N i)}; + +if (!$hmac) { + print STDERR "HMAC-SHA1 not requested\n"; + exit 3; +} +elsif (!defined($in) || $in ne '-') { + $in //= '(none)'; + print STDERR "Unexpected input file: $in\n"; + exit 3; +} + +my $challenge = <STDIN>; + +my $mock = $ENV{YKCHALRESP_MOCK} || ''; +if ($mock eq 'block') { + if ($nonblocking) { + print STDERR "Yubikey core error: operation would block\n"; + exit 1; + } + sleep 2; + succeed(); +} +elsif ($mock eq 'error') { + my $resp = $ENV{YKCHALRESP_ERROR} || 'not yet implemented'; + print STDERR "Yubikey core error: $resp\n"; + exit 1; +} +elsif ($mock eq 'usberror') { + print STDERR "USB error: something happened\n"; + exit 1; +} +else { # OK + succeed(); +} + +sub succeed { + my $resp = $ENV{YKCHALRESP_RESPONSE} || 'f000000000000000000000000000000000000000'; + print "$resp\n"; + exit 0; +} + +exit 2; diff --git a/t/files/bin/ykinfo b/t/files/bin/ykinfo new file mode 100755 index 0000000..a8cc021 --- /dev/null +++ b/t/files/bin/ykinfo @@ -0,0 +1,37 @@ +#!/usr/bin/env perl + +# This is a fake ykinfo program that provides canned responses, for testing. + +use warnings; +use strict; + +use Getopt::Std; + +our ($opt_a, $opt_n); +getopts('an:'); + +my $device = $opt_n // -1; + +if ($device == 0) { + print q{serial: 123 +version: 2.0.0 +touch_level: 0 +vendor_id: 1050 +product_id: 113 +}; + exit 0; +} +elsif ($device == 1) { + print q{serial: 456 +version: 3.0.1 +touch_level: 10 +vendor_id: 1050 +product_id: 401 +}; + exit 0; +} +else { + print STDERR "Yubikey core error: no yubikey present\n"; + exit 1; +} + diff --git a/t/files/keys/binary.key b/t/files/keys/binary.key new file mode 100644 index 0000000..e07f501 --- /dev/null +++ b/t/files/keys/binary.key @@ -0,0 +1 @@ +BYÆæ ðé wJ׎ôA/à } ¼ð=—dI \ No newline at end of file diff --git a/t/files/keys/hashed.key b/t/files/keys/hashed.key new file mode 100644 index 0000000..2f28ba4 --- /dev/null +++ b/t/files/keys/hashed.key @@ -0,0 +1 @@ +We are all Satoshi. diff --git a/t/files/keys/hex.key b/t/files/keys/hex.key new file mode 100644 index 0000000..7bf7fbc --- /dev/null +++ b/t/files/keys/hex.key @@ -0,0 +1 @@ +425903c6e61b0cf0e90d774ad78ef41305412fe009047da0bcf03d9713641449 \ No newline at end of file diff --git a/t/files/keys/xmlv1.key b/t/files/keys/xmlv1.key new file mode 100644 index 0000000..856e510 --- /dev/null +++ b/t/files/keys/xmlv1.key @@ -0,0 +1,11 @@ +<?xml version="1.0" encoding="UTF-8"?> +<KeyFile> + <Meta> + <Version>1.0</Version> + </Meta> + <Key> + <Data> + OF9tj+tfww1kHNWQaJlZWIlBdoTVXOazP8g/vZK7NcI= + </Data> + </Key> +</KeyFile> diff --git a/t/files/keys/xmlv2.key b/t/files/keys/xmlv2.key new file mode 100644 index 0000000..cb49062 --- /dev/null +++ b/t/files/keys/xmlv2.key @@ -0,0 +1,12 @@ +<?xml version="1.0" encoding="UTF-8"?> +<KeyFile> + <Meta> + <Version>2.0</Version> + </Meta> + <Key> + <Data Hash="984A141E"> + 385F6D8F EB5FC30D 641CD590 68995958 + 89417684 D55CE6B3 3FC83FBD 92BB35C2 + </Data> + </Key> +</KeyFile> diff --git a/t/group.t b/t/group.t new file mode 100644 index 0000000..af0998b --- /dev/null +++ b/t/group.t @@ -0,0 +1,22 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Group; +use File::KDBX; +use Test::More; + +subtest 'Path' => sub { + my $kdbx = File::KDBX->new; + my $group_a = $kdbx->add_group(name => 'Group A'); + my $group_b = $group_a->add_group(name => 'Group B'); + is $kdbx->root->path, 'Root', 'Root group has path'; + is $group_a->path, 'Group A', 'Layer 1 group has path'; + is $group_b->path, 'Group A.Group B', 'Layer 2 group has path'; +}; + +done_testing; diff --git a/t/hash-block.t b/t/hash-block.t new file mode 100644 index 0000000..b42aa23 --- /dev/null +++ b/t/hash-block.t @@ -0,0 +1,70 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon qw(:no_warnings_test); + +use File::KDBX::Util qw(can_fork); +use IO::Handle; +use File::KDBX::IO::HashBlock; +use Test::More; + +{ + my $expected_plaintext = 'Tiny food from Spain!'; + + pipe(my $read, my $write) or die "pipe failed: $!\n"; + + $write = File::KDBX::IO::HashBlock->new($write, block_size => 3); + print $write $expected_plaintext; + close($write) or die "close failed: $!"; + + $read = File::KDBX::IO::HashBlock->new($read); + my $plaintext = do { local $/; <$read> }; + close($read); + + is $plaintext, $expected_plaintext, 'Hash-block just a little bit'; +} + +SKIP: { + skip 'fork required to test long data streams' if !can_fork; + + my $expected_plaintext = "\x64" x (1024*1024*12 - 57); + + local $SIG{CHLD} = 'IGNORE'; + pipe(my $read, my $write) or die "pipe failed: $!\n"; + + defined(my $pid = fork) or die "fork failed: $!\n"; + if ($pid == 0) { + $write = File::KDBX::IO::HashBlock->new($write); + print $write $expected_plaintext; + close($write) or die "close failed: $!"; + # exit; + require POSIX; + POSIX::_exit(0); + } + + $read = File::KDBX::IO::HashBlock->new($read); + my $plaintext = do { local $/; <$read> }; + close($read); + + is $plaintext, $expected_plaintext, 'Hash-block a lot'; +} + +subtest 'Error handling' => sub { + pipe(my $read, my $write) or die "pipe failed: $!\n"; + + $read = File::KDBX::IO::HashBlock->new($read); + + print $write 'blah blah blah'; + close($write) or die "close failed: $!"; + + is $read->error, '', 'Read handle starts out fine'; + my $data = do { local $/; <$read> }; + is $read->error, 1, 'Read handle can enter an error state'; + + like $File::KDBX::IO::HashBlock::ERROR, qr/invalid block index/i, 'Error object is available'; +}; + +done_testing; diff --git a/t/hmac-block.t b/t/hmac-block.t new file mode 100644 index 0000000..87f2809 --- /dev/null +++ b/t/hmac-block.t @@ -0,0 +1,74 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon qw(:no_warnings_test); + +use File::KDBX::IO::HmacBlock; +use File::KDBX::Util qw(can_fork); +use IO::Handle; +use Test::More; + +my $KEY = "\x01" x 64; + +{ + my $expected_plaintext = 'Tiny food from Spain!'; + + pipe(my $read, my $write) or die "pipe failed: $!\n"; + + $write = File::KDBX::IO::HmacBlock->new($write, block_size => 3, key => $KEY); + print $write $expected_plaintext; + close($write) or die "close failed: $!"; + + $read = File::KDBX::IO::HmacBlock->new($read, key => $KEY); + my $plaintext = do { local $/; <$read> }; + close($read); + + is $plaintext, $expected_plaintext, 'HMAC-block just a little bit'; + + is $File::KDBX::IO::HmacBlock::ERROR, undef, 'No error when successful'; +} + +SKIP: { + skip 'fork required to test long data streams' if !can_fork; + + my $expected_plaintext = "\x64" x (1024*1024*12 - 57); + + local $SIG{CHLD} = 'IGNORE'; + pipe(my $read, my $write) or die "pipe failed: $!\n"; + + defined(my $pid = fork) or die "fork failed: $!\n"; + if ($pid == 0) { + $write = File::KDBX::IO::HmacBlock->new($write, key => $KEY); + print $write $expected_plaintext; + close($write) or die "close failed: $!"; + # exit; + require POSIX; + POSIX::_exit(0); + } + + $read = File::KDBX::IO::HmacBlock->new($read, key => $KEY); + my $plaintext = do { local $/; <$read> }; + close($read); + + is $plaintext, $expected_plaintext, 'HMAC-block a lot'; +} + +subtest 'Error handling' => sub { + pipe(my $read, my $write) or die "pipe failed: $!\n"; + + $read = File::KDBX::IO::HmacBlock->new($read, key => $KEY); + + print $write 'blah blah blah'; + close($write) or die "close failed: $!"; + + is $read->error, '', 'Read handle starts out fine'; + my $data = do { local $/; <$read> }; + is $read->error, 1, 'Read handle can enter an error state'; + + like $File::KDBX::IO::HmacBlock::ERROR, qr/failed to read HMAC/i, 'Error object is available'; +}; + +done_testing; diff --git a/t/iterator.t b/t/iterator.t new file mode 100644 index 0000000..02d4733 --- /dev/null +++ b/t/iterator.t @@ -0,0 +1,101 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Iterator; +use File::KDBX::Entry; +use File::KDBX::Util qw(:load); +use Iterator::Simple qw(:all); +use Test::More; + +subtest 'Basic' => sub { + my $it = File::KDBX::Iterator->new(1..10); + + is $it->(), 1, 'Get next item (1)'; + is $it->(), 2, 'Get next item (2)'; + $it->unget(-5); + is $it->(), -5, 'Unget'; + is $it->peek, 3, 'Peek at next'; + is $it->(), 3, 'Get next item (3)'; + is $it->count, 7, 'Get current size'; + + my $limited = $it->limit(3); + is $limited->count, 3, 'Get current size'; + my $enum = ienumerate $limited; + is_deeply $enum->to_array, [[0, 4], [1, 5], [2, 6]], 'Use Iterator::Simple functions'; + + is $it->(), 7, 'Original iterator is drained by composing iterator'; + + is $it->next(sub { $_ == 9 }), 9, 'Find next matching item'; + is $it->next, 10, 'Item got skipped while finding next match'; + is $it->peek, undef, 'No more items (peek)'; + is $it->next, undef, 'No more items (next)'; + + $it->(qw{10 20 30}); + is_deeply [$it->each], [qw{10 20 30}], 'Fill buffer and get each item (list)'; + is $it->(), undef, 'Empty'; + + $it->(my $buffer = [qw{a b c}]); + my @each; + $it->each(sub { push @each, $_ }); + is_deeply \@each, [qw{a b c}], 'Fill buffer and get each item (function)'; + is_deeply $buffer, [], 'Buffer is empty'; +}; + +subtest 'Sorting' => sub { + my $new_it = sub { + File::KDBX::Iterator->new( + File::KDBX::Entry->new(label => 'foo', icon_id => 1), + File::KDBX::Entry->new(label => 'bar', icon_id => 5), + File::KDBX::Entry->new(label => 'BaZ', icon_id => 3), + File::KDBX::Entry->new(label => 'qux', icon_id => 2), + File::KDBX::Entry->new(label => 'Muf', icon_id => 4), + ); + }; + + my @sort = (label => collate => 0); + + my $it = $new_it->(); + is_deeply $it->sort_by(@sort)->map(sub { $_->label })->to_array, + [qw{BaZ Muf bar foo qux}], 'Sort text ascending'; + + $it = $new_it->(); + is_deeply $it->sort_by(@sort, case => 0)->map(sub { $_->label })->to_array, + [qw{bar BaZ foo Muf qux}], 'Sort text ascending, ignore-case'; + + $it = $new_it->(); + is_deeply $it->sort_by(@sort, ascending => 0)->map(sub { $_->label })->to_array, + [qw{qux foo bar Muf BaZ}], 'Sort text descending'; + + $it = $new_it->(); + is_deeply $it->sort_by(@sort, ascending => 0, case => 0)->map(sub { $_->label })->to_array, + [qw{qux Muf foo BaZ bar}], 'Sort text descending, ignore-case'; + + SKIP: { + plan skip_all => 'Unicode::Collate required to test collation sorting' + if !try_load_optional('Unicode::Collate'); + + # FIXME I'm missing something.... + # $it = $new_it->(); + # is_deeply $it->sort_by('label')->map(sub { $_->label })->to_array, + # [qw{BaZ Muf bar foo qux}], 'Sort text ascending using Unicode::Collate'; + + $it = $new_it->(); + is_deeply $it->sort_by('label', case => 0)->map(sub { $_->label })->to_array, + [qw{bar BaZ foo Muf qux}], 'Sort text ascending, ignore-case using Unicode::Collate'; + } + + $it = $new_it->(); + is_deeply $it->nsort_by('icon_id')->map(sub { $_->label })->to_array, + [qw{foo qux BaZ Muf bar}], 'Sort text numerically, ascending'; + + $it = $new_it->(); + is_deeply $it->nsort_by('icon_id', ascending => 0)->map(sub { $_->label })->to_array, + [qw{bar Muf BaZ qux foo}], 'Sort text numerically, descending'; +}; + +done_testing; diff --git a/t/kdb.t b/t/kdb.t new file mode 100644 index 0000000..02927e8 --- /dev/null +++ b/t/kdb.t @@ -0,0 +1,199 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use Encode qw(decode); +use File::KDBX; +use Test::Deep; +use Test::More; + +eval { require File::KeePass; require File::KeePass::KDBX } + or plan skip_all => 'File::KeePass and File::KeePass::KDBX required to test KDB files'; + +my $kdbx = File::KDBX->load(testfile('basic.kdb'), 'masterpw'); + +sub test_basic { + my $kdbx = shift; + + cmp_deeply $kdbx->headers, superhashof({ + cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377", + encryption_iv => "\250\354q\362\13\247\353\247\222!\232\364Lj\315w", + master_seed => "\212z\356\256\340+\n\243ms2\364'!7\216", + transform_rounds => 713, + transform_seed => "\227\264\n^\230\2\301:!f\364\336\251\277\241[\3`\314RG\343\16U\333\305eT3:\240\257", + }), 'Get expected headers from KDB file' or diag explain $kdbx->headers; + + is keys %{$kdbx->deleted_objects}, 0, 'There are no deleted objects' or dumper $kdbx->deleted_objects; + is scalar @{$kdbx->root->groups}, 2, 'Root group has two children'; + + my $group1 = $kdbx->root->groups->[0]; + isnt $group1->uuid, undef, 'Group 1 has a UUID'; + is $group1->name, 'Internet', 'Group 1 has a name'; + is scalar @{$group1->groups}, 2, 'Group 1 has subgroups'; + is scalar @{$group1->entries}, 2, 'Group 1 has entries'; + is $group1->icon_id, 1, 'Group 1 has an icon'; + + my ($entry11, $entry12, @other) = @{$group1->entries}; + + isnt $entry11->uuid, undef, 'Entry has a UUID'; + is $entry11->title, 'Test entry', 'Entry has a title'; + is $entry11->icon_id, 1, 'Entry has an icon'; + is $entry11->username, 'I', 'Entry has a username'; + is $entry11->url, 'http://example.com/', 'Entry has a URL'; + is $entry11->password, 'secretpassword', 'Entry has a password'; + is $entry11->notes, "Lorem ipsum\ndolor sit amet", 'Entry has notes'; + ok $entry11->expires, 'Entry is expired'; + is $entry11->expiry_time, 'Wed May 9 10:32:00 2012', 'Entry has an expiration time'; + is scalar keys %{$entry11->binaries}, 1, 'Entry has a binary'; + is $entry11->binary_value('attachment.txt'), "hello world\n", 'Entry has a binary'; + + is $entry12->title, '', 'Entry 2 has an empty title'; + is $entry12->icon_id, 0, 'Entry 2 has an icon'; + is $entry12->username, '', 'Entry 2 has an empty username'; + is $entry12->url, '', 'Entry 2 has an empty URL'; + is $entry12->password, '', 'Entry 2 has an empty password'; + is $entry12->notes, '', 'Entry 2 has empty notes'; + ok !$entry12->expires, 'Entry 2 is not expired'; + is scalar keys %{$entry12->binaries}, 0, 'Entry has no binaries'; + + my $group11 = $group1->groups->[0]; + is $group11->label, 'Subgroup 1', 'Group has subgroup'; + is scalar @{$group11->groups}, 1, 'Subgroup has subgroup'; + + my $group111 = $group11->groups->[0]; + is $group111->label, 'Unexpanded', 'Has unexpanded group'; + is scalar @{$group111->groups}, 1, 'Subgroup has subgroup'; + + my $group1111 = $group111->groups->[0]; + is $group1111->label, 'abc', 'Group has subsubsubroup'; + is scalar @{$group1111->groups}, 0, 'No more subgroups'; + + my $group12 = $group1->groups->[1]; + is $group12->label, 'Subgroup 2', 'Group has another subgroup'; + is scalar @{$group12->groups}, 0, 'No more subgroups'; + + my $group2 = $kdbx->root->groups->[1]; + is $group2->label, 'eMail', 'Root has another subgroup'; + is scalar @{$group2->entries}, 1, 'eMail group has an entry'; + is $group2->icon_id, 19, 'Group has a standard icon'; +} +for my $test ( + ['Basic' => $kdbx], + ['Basic after dump & load roundtrip' + => File::KDBX->load_string($kdbx->dump_string('a', randomize_seeds => 0), 'a')], +) { + my ($name, $kdbx) = @$test; + subtest $name, \&test_basic, $kdbx; +} + +sub test_custom_icons { + my $kdbx = shift; + $kdbx = $kdbx->() if ref $kdbx eq 'CODE'; + + my ($icon, @other) = @{$kdbx->custom_icons}; + ok $icon, 'Database has a custom icon'; + is scalar @other, 0, 'Database has no other icons'; + + like $icon->{data}, qr/^\x89PNG\r\n/, 'Custom icon is a PNG'; +} +for my $test ( + ['Custom icons' => $kdbx], + ['Custom icons after dump & load roundtrip' => sub { + File::KDBX->load_string($kdbx->dump_string('a', allow_upgrade => 0, randomize_seeds => 0), 'a'); + }], +) { + my ($name, $kdbx) = @$test; + subtest $name, \&test_custom_icons, $kdbx; +} + +subtest 'Group expansion' => sub { + is $kdbx->root->groups->[0]->is_expanded, 1, 'Group is expanded'; + is $kdbx->root->groups->[0]->groups->[0]->is_expanded, 1, 'Subgroup is expanded'; + is $kdbx->root->groups->[0]->groups->[0]->groups->[0]->is_expanded, 0, 'Subsubgroup is not expanded'; +}; + +subtest 'Autotype' => sub { + my $group = $kdbx->root->groups->[0]->groups->[0]; + is scalar @{$group->entries}, 2, 'Group has two entries'; + + my ($entry1, $entry2) = @{$group->entries}; + + is $entry1->notes, "\nlast line", 'First entry has a note'; + TODO: { + local $TODO = 'File::KeePass fails to parse out the default key sequence'; + is $entry1->auto_type->{default_sequence}, '{USERNAME}{ENTER}', 'First entry has a default sequence'; + }; + cmp_deeply $entry1->auto_type->{associations}, set( + { + keystroke_sequence => "{USERNAME}{ENTER}", + window => "a window", + }, + { + keystroke_sequence => "{USERNAME}{ENTER}", + window => "a second window", + }, + { + keystroke_sequence => "{PASSWORD}{ENTER}", + window => "Window Nr 1a", + }, + { + keystroke_sequence => "{PASSWORD}{ENTER}", + window => "Window Nr 1b", + }, + { + keystroke_sequence => "{USERNAME}{ENTER}", + window => "Window 2", + }, + ), 'First entry has auto-type window associations'; + + is $entry2->notes, "start line\nend line", 'Second entry has notes'; + TODO: { + local $TODO = 'File::KeePass fails to parse out the default key sequence'; + is $entry2->auto_type->{default_sequence}, '', 'Second entry has no default sequence'; + cmp_deeply $entry2->auto_type->{associations}, set( + { + keystroke_sequence => "", + window => "Main Window", + }, + { + keystroke_sequence => "", + window => "Test Window", + }, + ), 'Second entry has auto-type window associations' or diag explain $entry2->auto_type->{associations}; + }; +}; + +subtest 'KDB file keys' => sub { + while (@_) { + my ($name, $key) = splice @_, 0, 2; + my $kdb_filepath = testfile("$name.kdb"); + my $kdbx = File::KDBX->load($kdb_filepath, $key); + + is $kdbx->root->name, $name, "Loaded KDB database with root group is named $name"; + } +}, ( + FileKeyBinary => {file => testfile('FileKeyBinary.key')}, + FileKeyHex => {file => testfile('FileKeyHex.key')}, + FileKeyHashed => {file => testfile('FileKeyHashed.key')}, + CompositeKey => ['mypassword', {file => testfile('FileKeyHex.key')}], +); + +subtest 'Twofish' => sub { + plan skip_all => 'File::KeePass does not implement the Twofish cipher'; + my $name = 'Twofish'; + my $kdbx = File::KDBX->load(testfile("$name.kdb"), 'masterpw'); + is $kdbx->root->name, $name, "Loaded KDB database with root group is named $name"; +}; + +subtest 'CP-1252 password' => sub { + my $name = 'CP-1252'; + my $kdbx = File::KDBX->load(testfile("$name.kdb"), + decode('UTF-8', "\xe2\x80\x9e\x70\x61\x73\x73\x77\x6f\x72\x64\xe2\x80\x9d")); + is $kdbx->root->name, $name, "Loaded KDB database with root group is named $name"; +}; + +done_testing; diff --git a/t/kdbx2.t b/t/kdbx2.t new file mode 100644 index 0000000..958348a --- /dev/null +++ b/t/kdbx2.t @@ -0,0 +1,100 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX; +use File::KDBX::Constants qw(:version :kdf); +use Test::Deep; +use Test::More; + +my $kdbx = File::KDBX->load(testfile('Format200.kdbx'), 'a'); + +verify_kdbx2($kdbx, KDBX_VERSION_2_0); +is $kdbx->kdf->uuid, KDF_UUID_AES, 'KDBX2 file has a usable KDF configured'; + +my $dump; +like warning { $dump = $kdbx->dump_string('a', randomize_seeds => 0) }, qr/upgrading database/i, + 'There is a warning about a change in file version when writing'; + +my $kdbx_from_dump = File::KDBX->load_string($dump, 'a'); +verify_kdbx2($kdbx_from_dump, KDBX_VERSION_3_1); +is $kdbx->kdf->uuid, KDF_UUID_AES, 'New KDBX3 file has the same KDF'; + +sub verify_kdbx2 { + my $kdbx = shift; + my $vers = shift; + + ok_magic $kdbx, $vers, 'Get the correct KDBX2 file magic'; + + cmp_deeply $kdbx->headers, superhashof({ + cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377", + compression_flags => 1, + encryption_iv => "D+VZ\277\274>\226K\225\3237\255\231\35\4", + inner_random_stream_id => 2, + inner_random_stream_key => "\214\aW\253\362\177<\346n`\263l\245\353T\25\261BnFp\177\357\335\36(b\372z\231b\355", + kdf_parameters => { + "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352", + R => 6000, + S => "S\202\207A\3475\265\177\220\331\263[\334\326\365\324B\\\2222zb-f\263m\220\333S\361L\332", + }, + master_seed => "\253!\2\241\r*|{\227\0276Lx\215\32\\\17\372d\254\255*\21r\376\251\313+gMI\343", + stream_start_bytes => "\24W\24\3262oU\t>\242B\2666:\231\377\36\3\353 \217M\330U\35\367|'\230\367\221^", + }), 'Get expected headers from KDBX2 file' or diag explain $kdbx->headers; + + cmp_deeply $kdbx->meta, superhashof({ + custom_data => {}, + database_description => "", + database_description_changed => obj_isa('Time::Piece'), + database_name => "", + database_name_changed => obj_isa('Time::Piece'), + default_username => "", + default_username_changed => obj_isa('Time::Piece'), + entry_templates_group => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", + entry_templates_group_changed => obj_isa('Time::Piece'), + generator => ignore(), + last_selected_group => "\226Y\251\22\356zB\@\214\222ns\273a\263\221", + last_top_visible_group => "\226Y\251\22\356zB\@\214\222ns\273a\263\221", + maintenance_history_days => 365, + memory_protection => superhashof({ + protect_notes => bool(0), + protect_password => bool(0), + protect_title => bool(0), + protect_url => bool(1), + protect_username => bool(1), + }), + recycle_bin_changed => obj_isa('Time::Piece'), + recycle_bin_enabled => bool(1), + recycle_bin_uuid => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", + }), 'Get expected metadata from KDBX2 file' or diag explain $kdbx->meta; + + $kdbx->unlock; + + is scalar @{$kdbx->root->entries}, 1, 'Get one entry in root'; + + my $entry = $kdbx->root->entries->[0]; + is $entry->title, 'Sample Entry', 'Get the correct title'; + is $entry->username, 'User Name', 'Get the correct username'; + + cmp_deeply $entry->binaries, { + "myattach.txt" => { + value => "abcdefghijk", + }, + "test.txt" => { + value => "this is a test", + }, + }, 'Get two attachments from the entry' or diag explain $entry->binaries; + + my @history = @{$entry->history}; + is scalar @history, 2, 'Get two historical entries'; + is scalar keys %{$history[0]->binaries}, 0, 'First historical entry has no attachments'; + is scalar keys %{$history[1]->binaries}, 1, 'Second historical entry has one attachment'; + cmp_deeply $history[1]->binary('myattach.txt'), { + value => 'abcdefghijk', + }, 'The attachment has the correct content'; +} + +done_testing; diff --git a/t/kdbx3.t b/t/kdbx3.t new file mode 100644 index 0000000..5fe53f7 --- /dev/null +++ b/t/kdbx3.t @@ -0,0 +1,133 @@ +#!/usr/bin/env perl + +use utf8; +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX; +use File::KDBX::Constants qw(:version); +use Test::Deep; +use Test::More; + +subtest 'Verify Format300' => sub { + my $kdbx = File::KDBX->load(testfile('Format300.kdbx'), 'a'); + + ok_magic $kdbx, KDBX_VERSION_3_0, 'Get the correct KDBX3 file magic'; + + cmp_deeply $kdbx->headers, { + cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377", + compression_flags => 1, + encryption_iv => "\214\306\310\0322\a9P\230\306\253\326\17\214\344\255", + inner_random_stream_id => 2, + inner_random_stream_key => "\346\n8\2\322\264i\5\5\274\22\377+\16tB\353\210\1\2m\2U%\326\347\355\313\313\340A\305", + kdf_parameters => { + "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352", + R => 6000, + S => "\340\377\235\255\222o\1(\226m\373\tC{K\352\f\332M\302|~P\e\346J\@\275A\227\236\366", + }, + master_seed => "Z\230\355\353\2303\361\237-p\345\27nM\22<E\252\314k\20\257\302\343p\"y\5sfw ", + stream_start_bytes => "\276\277jI1_\325\a\375\22\3\366\2V\"\316\370\316E\250B\317\232\232\207K\345.P\256b/", + }, 'Extract headers' or diag explain $kdbx->headers; + + is $kdbx->meta->{database_name}, 'Test Database Format 0x00030000', 'Extract database name from meta'; + is $kdbx->root->name, 'Format300', 'Extract name of root group'; +}; + +subtest 'Verify NonAscii' => sub { + my $kdbx = File::KDBX->load(testfile('NonAscii.kdbx'), 'Δöض'); + + ok_magic $kdbx, KDBX_VERSION_3_1, 'Get the correct KDBX3 file magic'; + + cmp_deeply $kdbx->headers, { + cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377", + compression_flags => 0, + encryption_iv => "\264\256\210m\311\312s\274U\206\t^\202\323\365]", + inner_random_stream_id => 2, + inner_random_stream_key => "Z\244]\373\13`\2108=>\r\224\351\373\316\276\253\6\317z\356\302\36\fW\1776Q\366\32\34,", + kdf_parameters => { + "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352", + R => 6000, + S => "l\254\250\255\240U\313\364\336\316#\254\306\231\f%U\207J\235\275\34\b\25036\26\241\a\300\26\332", + }, + master_seed => "\13\350\370\214{\0276\17dv\31W[H\26\272\4\335\377\356\275N\"\2A1\364\213\226\237\303M", + stream_start_bytes => "\220Ph\27\"h\233^\263mf\3339\262U\313\236zF\f\23\b9\323\346=\272\305})\240T", + }, 'Extract headers' or diag explain $kdbx->headers; + + is $kdbx->meta->{database_name}, 'NonAsciiTest', 'Extract database name from meta'; +}; + +subtest 'Verify Compressed' => sub { + my $kdbx = File::KDBX->load(testfile('Compressed.kdbx'), ''); + + ok_magic $kdbx, KDBX_VERSION_3_1, 'Get the correct KDBX3 file magic'; + + cmp_deeply $kdbx->headers, { + cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377", + compression_flags => 1, + encryption_iv => "Z(\313\342\212x\f\326\322\342\313\320\352\354:S", + inner_random_stream_id => 2, + inner_random_stream_key => "+\232\222\302\20\333\254\342YD\371\34\373,\302:\303\247\t\26\$\a\370g\314\32J\240\371;U\234", + kdf_parameters => { + "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352", + R => 6000, + S => "\3!\230hx\363\220nV\23\340\316\262\210\26Z\al?\343\240\260\325\262\31i\223y\b\306\344V", + }, + master_seed => "\0206\244\265\203m14\257T\372o\16\271\306\347\215\365\376\304\20\356\344\3713\3\303\363\a\5\205\325", + stream_start_bytes => "i%Ln\30\r\261\212Q\266\b\201\et\342\203\203\374\374E\303\332\277\320\13\304a\223\215#~\266", + }, 'Extract headers' or diag explain $kdbx->headers; + + is $kdbx->meta->{database_name}, 'Compressed', 'Extract database name from meta'; +}; + +subtest 'Verify ProtectedStrings' => sub { + my $kdbx = File::KDBX->load(testfile('ProtectedStrings.kdbx'), 'masterpw'); + + ok_magic $kdbx, KDBX_VERSION_3_1, 'Get the correct KDBX3 file magic'; + + cmp_deeply $kdbx->headers, { + cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377", + compression_flags => 1, + encryption_iv => "\0177y\356&\217\215\244\341\312\317Z\246m\363\251", + inner_random_stream_id => 2, + inner_random_stream_key => "%M\333Z\345\22T\363\257\27\364\206\352\334\r\3\361\250\360\314\213\253\237\23B\252h\306\243(7\13", + kdf_parameters => ignore(), + kdf_parameters => { + "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352", + R => 6000, + S => "y\251\327\312mW8B\351\273\364#T#m:\370k1\240v\360E\245\304\325\265\313\337\245\211E", + }, + master_seed => "\355\32<1\311\320\315\24\204\325\250\35+\2525\321\224x?\361\355\310V\322\20\331\324\"\372\334\210\233", + stream_start_bytes => "D#\337\260,\340.\276\312\302N\336y\233\275\360\250|\272\346*.\360\256\232\220\263>\303\aQ\371", + }, 'Extract headers' or diag explain $kdbx->headers; + + is $kdbx->meta->{database_name}, 'Protected Strings Test', 'Extract database name from meta'; + + $kdbx->unlock; + + my $entry = $kdbx->entries->next; + is $entry->title, 'Sample Entry', 'Get entry title'; + is $entry->username, 'Protected User Name', 'Get protected username from entry'; + is $entry->password, 'ProtectedPassword', 'Get protected password from entry'; + is $entry->string_value('TestProtected'), 'ABC', 'Get ABC string from entry'; + is $entry->string_value('TestUnprotected'), 'DEF', 'Get DEF string from entry'; + + ok $kdbx->meta->{memory_protection}{protect_password}, 'Memory protection is ON for passwords'; + ok $entry->string('TestProtected')->{protect}, 'Protection is ON for TestProtected'; + ok !$entry->string('TestUnprotected')->{protect}, 'Protection is OFF for TestUnprotected'; +}; + +subtest 'Verify BrokenHeaderHash' => sub { + like exception { File::KDBX->load(testfile('BrokenHeaderHash.kdbx'), '') }, + qr/header hash does not match/i, 'Fail to load a database with a corrupted header hash'; +}; + +subtest 'Dump and load' => sub { + my $kdbx = File::KDBX->new; + my $dump = $kdbx->dump_string('foo'); + ok $dump; +}; + +done_testing; diff --git a/t/kdbx4.t b/t/kdbx4.t new file mode 100644 index 0000000..f1e9cbc --- /dev/null +++ b/t/kdbx4.t @@ -0,0 +1,219 @@ +#!/usr/bin/env perl + +use utf8; +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX; +use File::KDBX::Constants qw(:version :kdf); +use Test::Deep; +use Test::More; +use boolean qw(:all); + +subtest 'Verify Format400' => sub { + my $kdbx = File::KDBX->load(testfile('Format400.kdbx'), 't'); + $kdbx->unlock; + + ok_magic $kdbx, KDBX_VERSION_4_0, 'Get the correct KDBX4 file magic'; + + cmp_deeply $kdbx->headers, { + cipher_id => "\326\3\212+\213oL\265\245\$3\2321\333\265\232", + compression_flags => 1, + encryption_iv => "3?\207P\233or\220\215h\2240", + kdf_parameters => { + "\$UUID" => "\357cm\337\214)DK\221\367\251\244\3\343\n\f", + I => 2, + M => 1048576, + P => 2, + S => "V\254\6m-\206*\260\305\f\0\366\24:4\235\364A\362\346\221\13)}\250\217P\303\303\2\331\245", + V => 19, + }, + master_seed => ";\372y\300yS%\3331\177\231\364u\265Y\361\225\3273h\332R,\22\240a\240\302\271\357\313\23", + }, 'Extract headers' or diag explain $kdbx->headers; + + is $kdbx->meta->{database_name}, 'Format400', 'Extract database name from meta'; + is $kdbx->root->name, 'Format400', 'Extract name of root group'; + + my ($entry, @other) = $kdbx->entries->grep(\'400', 'title')->each; + is scalar @other, 0, 'Database has one entry'; + + is $entry->title, 'Format400', 'Entry is titled'; + is $entry->username, 'Format400', 'Entry has a username set'; + is keys %{$entry->strings}, 6, 'Entry has six strings'; + is $entry->string_value('Format400'), 'Format400', 'Entry has a custom string'; + is keys %{$entry->binaries}, 1, 'Entry has one binary'; + is $entry->binary_value('Format400'), "Format400\n", 'Entry has a binary string'; +}; + +subtest 'KDBX4 upgrade' => sub { + my $kdbx = File::KDBX->new; + + $kdbx->kdf_parameters->{+KDF_PARAM_UUID} = KDF_UUID_AES_CHALLENGE_RESPONSE; + is $kdbx->minimum_version, KDBX_VERSION_4_0, 'AES challenge-response KDF requires upgrade'; + $kdbx->kdf_parameters->{+KDF_PARAM_UUID} = KDF_UUID_ARGON2D; + is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Argon2D KDF requires upgrade'; + $kdbx->kdf_parameters->{+KDF_PARAM_UUID} = KDF_UUID_ARGON2ID; + is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Argon2ID KDF requires upgrade'; + $kdbx->kdf_parameters->{+KDF_PARAM_UUID} = KDF_UUID_AES; + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + + $kdbx->public_custom_data->{foo} = 42; + is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Public custom data requires upgrade'; + delete $kdbx->public_custom_data->{foo}; + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + + my $entry = $kdbx->add_entry; + $entry->custom_data(foo => 'bar'); + is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Entry custom data requires upgrade'; + delete $entry->custom_data->{foo}; + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + + my $group = $kdbx->add_group; + $group->custom_data(foo => 'bar'); + is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Group custom data requires upgrade'; + delete $group->custom_data->{foo}; + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; +}; + +subtest 'KDBX4.1 upgrade' => sub { + my $kdbx = File::KDBX->new; + + my $group1 = $kdbx->add_group(label => 'One'); + my $group2 = $kdbx->add_group(label => 'Two'); + my $entry1 = $kdbx->add_entry(label => 'Meh'); + + $group1->tags('hi'); + is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Groups with tags requires upgrade'; + $group1->tags(''); + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + + $entry1->quality_check(0); + is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Disable entry quality check requires upgrade'; + $entry1->quality_check(1); + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + + $group1->previous_parent_group($group2->uuid); + is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Previous parent group on group requires upgrade'; + $group1->previous_parent_group(undef); + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + + $entry1->previous_parent_group($group2->uuid); + is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Previous parent group on entry requires upgrade'; + $entry1->previous_parent_group(undef); + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + + $kdbx->add_custom_icon('data'); + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Icon with no metadata requires no upgrade'; + my $icon_uuid = $kdbx->add_custom_icon('data2', name => 'icon name'); + is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Icon with name requires upgrade'; + $kdbx->remove_custom_icon($icon_uuid); + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + $icon_uuid = $kdbx->add_custom_icon('data2', last_modification_time => gmtime); + is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Icon with modtime requires upgrade'; + $kdbx->remove_custom_icon($icon_uuid); + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + + $entry1->custom_data(foo => 'bar', last_modification_time => scalar gmtime); + is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Entry custom data modtime requires upgrade'; + delete $entry1->custom_data->{foo}; + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; + + $group1->custom_data(foo => 'bar', last_modification_time => scalar gmtime); + is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Group custom data modtime requires upgrade'; + delete $group1->custom_data->{foo}; + is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement'; +}; + +sub test_upgrade_master_key_integrity { + my ($modifier, $expected_version) = @_; + plan tests => $expected_version >= KDBX_VERSION_4_0 ? 6 : 5; + + my $kdbx = File::KDBX->new; + $kdbx->kdf_parameters(fast_kdf); + + is $kdbx->kdf->uuid, KDF_UUID_AES, 'Default KDF is AES'; + + { + local $_ = $kdbx; + $modifier->($kdbx); + } + is $kdbx->minimum_version, $expected_version, + sprintf('Got expected minimum version after modification: %x', $kdbx->minimum_version); + + my $master_key = ['fffqcvq4rc', \'this is a keyfile', sub { 'chalresp 523rf2' }]; + my $dump; + warnings { $kdbx->dump_string(\$dump, $master_key) }; + ok $dump, 'Can dump the database' or diag explain $dump; + + like exception { File::KDBX->load_string($dump, 'wrong key') }, + qr/invalid credentials/i, 'Cannot load a KDBX with the wrong key'; + + # print STDERR "DUMP: [$dump]\n"; + + my $kdbx2 = File::KDBX->load_string($dump, $master_key); + + is $kdbx2->version, $expected_version, sprintf('Got expected version: %x', $kdbx2->version); + isnt $kdbx2->kdf->uuid, KDF_UUID_AES, 'No unexpected KDF' if $kdbx2->version >= KDBX_VERSION_4_0; + + # diag explain(File::KDBX->load_string($dump, $master_key, inner_format => 'Raw')->raw); +} +for my $test ( + [KDBX_VERSION_3_1, 'nothing', sub {}], + [KDBX_VERSION_3_1, 'AES KDF', sub { $_->kdf_parameters(fast_kdf(KDF_UUID_AES)) }], + [KDBX_VERSION_4_0, 'Argon2D KDF', sub { $_->kdf_parameters(fast_kdf(KDF_UUID_ARGON2D)) }], + [KDBX_VERSION_4_0, 'Argon2ID KDF', sub { $_->kdf_parameters(fast_kdf(KDF_UUID_ARGON2ID)) }], + [KDBX_VERSION_4_0, 'public custom data', sub { $_->public_custom_data->{foo} = 'bar' }], + [KDBX_VERSION_3_1, 'custom data', sub { $_->custom_data(foo => 'bar') }], + [KDBX_VERSION_4_0, 'root group custom data', sub { $_->root->custom_data(baz => 'qux') }], + [KDBX_VERSION_4_0, 'group custom data', sub { $_->add_group->custom_data(baz => 'qux') }], + [KDBX_VERSION_4_0, 'entry custom data', sub { $_->add_entry->custom_data(baz => 'qux') }], +) { + my ($expected_version, $name, $modifier) = @$test; + subtest "Master key integrity: $name" => \&test_upgrade_master_key_integrity, + $modifier, $expected_version; +} + +subtest 'Custom data' => sub { + my $kdbx = File::KDBX->new; + $kdbx->kdf_parameters(fast_kdf(KDF_UUID_AES)); + $kdbx->version(KDBX_VERSION_4_0); + + $kdbx->public_custom_data->{str} = '你好'; + $kdbx->public_custom_data->{num} = 42; + $kdbx->public_custom_data->{bool} = true; + $kdbx->public_custom_data->{bytes} = "\1\2\3\4"; + + my $group = $kdbx->add_group(label => 'Group'); + $group->custom_data(str => '你好'); + $group->custom_data(num => 42); + $group->custom_data(bool => true); + + my $entry = $kdbx->add_entry(label => 'Entry'); + $entry->custom_data(str => '你好'); + $entry->custom_data(num => 42); + $entry->custom_data(bool => false); + + my $dump = $kdbx->dump_string('a'); + my $kdbx2 = File::KDBX->load_string($dump, 'a'); + + is $kdbx2->public_custom_data->{str}, '你好', 'Store a string in public custom data'; + cmp_ok $kdbx2->public_custom_data->{num}, '==', 42, 'Store a number in public custom data'; + is $kdbx2->public_custom_data->{bool}, true, 'Store a boolean in public custom data'; + ok isBoolean($kdbx2->public_custom_data->{bool}), 'Boolean is indeed a boolean'; + is $kdbx2->public_custom_data->{bytes}, "\1\2\3\4", 'Store some bytes in public custom data'; + + my $group2 = $kdbx2->groups->grep(label => 'Group')->next; + is_deeply $group2->custom_data_value('str'), '你好', 'Store a string in group custom data'; + is_deeply $group2->custom_data_value('num'), '42', 'Store a number in group custom data'; + is_deeply $group2->custom_data_value('bool'), '1', 'Store a boolean in group custom data'; + + my $entry2 = $kdbx2->entries->grep(label => 'Entry')->next; + is_deeply $entry2->custom_data_value('str'), '你好', 'Store a string in entry custom data'; + is_deeply $entry2->custom_data_value('num'), '42', 'Store a number in entry custom data'; + is_deeply $entry2->custom_data_value('bool'), '0', 'Store a boolean in entry custom data'; +}; + +done_testing; diff --git a/t/kdf-aes-pp.t b/t/kdf-aes-pp.t new file mode 100644 index 0000000..55bfc82 --- /dev/null +++ b/t/kdf-aes-pp.t @@ -0,0 +1,27 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +BEGIN { $ENV{PERL_FILE_KDBX_XS} = 0 } + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::KDF; + +use File::KDBX::Constants qw(:kdf); +use Test::More; + +my $kdf = File::KDBX::KDF->new(uuid => KDF_UUID_AES, seed => "\1" x 32, rounds => 10); + +ok !File::KDBX::XS->can('kdf_aes_transform_half'), 'XS can be avoided'; + +my $r = $kdf->transform("\2" x 32); +is $r, "\342\234cp\375\\p\253]\213\f\246\345\230\266\260\r\222j\332Z\204:\322 p\224mhm\360\222", + 'AES KDF works without XS'; + +like exception { $kdf->transform("\2" x 33) }, qr/raw key must be 32 bytes/i, + 'Transformation requires valid arguments'; + +done_testing; diff --git a/t/kdf.t b/t/kdf.t new file mode 100644 index 0000000..99c37f4 --- /dev/null +++ b/t/kdf.t @@ -0,0 +1,45 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Constants qw(:kdf); +use File::KDBX::KDF; +use Test::More; + +subtest 'AES KDF' => sub { + my $kdf1 = File::KDBX::KDF->new(uuid => KDF_UUID_AES, seed => "\1" x 32, rounds => 10); + my $result1 = $kdf1->transform("\2" x 32); + is $result1, "\342\234cp\375\\p\253]\213\f\246\345\230\266\260\r\222j\332Z\204:\322 p\224mhm\360\222", + 'AES KDF basically works'; + + like exception { $kdf1->transform("\2" x 33) }, qr/raw key must be 32 bytes/i, + 'Transformation requires valid arguments'; +}; + +subtest 'Argon2 KDF' => sub { + my $kdf1 = File::KDBX::KDF->new( + uuid => KDF_UUID_ARGON2D, + salt => "\2" x 32, + iterations => 2, + parallelism => 2, + ); + my $r1 = $kdf1->transform("\2" x 32); + is $r1, "\352\333\247\347+x#\"C\340\224\30\316\350\3068E\246\347H\263\214V\310\5\375\16N.K\320\255", + 'Argon2D KDF works'; + + my $kdf2 = File::KDBX::KDF->new( + uuid => KDF_UUID_ARGON2ID, + salt => "\2" x 32, + iterations => 2, + parallelism => 3, + ); + my $r2 = $kdf2->transform("\2" x 32); + is $r2, "S\304\304u\316\311\202^\214JW{\312=\236\307P\345\253\323\313\23\215\247\210O!#F\16\1x", + 'Argon2ID KDF works'; +}; + +done_testing; diff --git a/t/keys.t b/t/keys.t new file mode 100644 index 0000000..65658e5 --- /dev/null +++ b/t/keys.t @@ -0,0 +1,124 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use Crypt::Misc 0.029 qw(decode_b64 encode_b64); +use File::KDBX::Constants qw(:key_file); +use File::KDBX::Key; +use File::Temp qw(tempfile); +use Test::More; + +subtest 'Primitives' => sub { + my $pkey = File::KDBX::Key->new('password'); + isa_ok $pkey, 'File::KDBX::Key::Password'; + is $pkey->raw_key, decode_b64('XohImNooBHFR0OVvjcYpJ3NgPQ1qq73WKhHvch0VQtg='), + 'Can calculate raw key from password' or diag encode_b64($pkey->raw_key); + + my $fkey = File::KDBX::Key->new(\'password'); + isa_ok $fkey, 'File::KDBX::Key::File'; + is $fkey->raw_key, decode_b64('XohImNooBHFR0OVvjcYpJ3NgPQ1qq73WKhHvch0VQtg='), + 'Can calculate raw key from file' or diag encode_b64($fkey->raw_key); + + my $ckey = File::KDBX::Key->new([ + $pkey, + $fkey, + 'another password', + File::KDBX::Key::File->new(testfile(qw{keys hashed.key})), + ]); + isa_ok $ckey, 'File::KDBX::Key::Composite'; + is $ckey->raw_key, decode_b64('FLV8/zOT9mEL8QKkzizq7mJflnb25ITblIPq608MGrk='), + 'Can calculate raw key from composite' or diag encode_b64($ckey->raw_key); +}; + +for my $test ( + [KEY_FILE_TYPE_XML, 'xmlv1.key', 'OF9tj+tfww1kHNWQaJlZWIlBdoTVXOazP8g/vZK7NcI=', '1.0'], + [KEY_FILE_TYPE_XML, 'xmlv2.key', 'OF9tj+tfww1kHNWQaJlZWIlBdoTVXOazP8g/vZK7NcI=', '2.0'], + [KEY_FILE_TYPE_BINARY, 'binary.key', 'QlkDxuYbDPDpDXdK1470EwVBL+AJBH2gvPA9lxNkFEk='], + [KEY_FILE_TYPE_HEX, 'hex.key', 'QlkDxuYbDPDpDXdK1470EwVBL+AJBH2gvPA9lxNkFEk='], + [KEY_FILE_TYPE_HASHED, 'hashed.key', '8vAO4mrMeq6iCa1FHeWm/Mj5al8HIv2ajqsqsSeUC6U='], +) { + my ($type) = @$test; + subtest "Load $type key file" => sub { + my ($type, $filename, $expected_key, $version) = @_; + + my $key = File::KDBX::Key::File->new(testfile('keys', $filename)); + is $key->raw_key, decode_b64($expected_key), + "Can calculate raw key from $type file" or diag encode_b64($key->raw_key); + is $key->type, $type, "File type is detected as $type"; + is $key->version, $version, "File version is detected as $version" if defined $version; + }, @$test; + + subtest "Save $type key file" => sub { + my ($type, $filename, $expected_key, $version) = @_; + + my ($fh, $filepath) = tempfile('keyfile-XXXXXX', TMPDIR => 1, UNLINK => 1, SUFFIX => '.key'); + note $filepath; + my $key = File::KDBX::Key::File->new( + filepath => $filepath, + type => $type, + version => $version, + raw_key => decode_b64($expected_key), + ); + + my $e = exception { $key->save }; + close($fh); + + if ($type == KEY_FILE_TYPE_HASHED) { + like $e, qr/invalid type/i, "Cannot save $type file"; + return; + } + is $e, undef, "Save $type file"; + + my $key2 = File::KDBX::Key::File->new($filepath); + is $key2->type, $key->type, 'Loaded key file has the same type'; + is $key2->raw_key, $key->raw_key, 'Loaded key file has the same raw key'; + }, @$test; +} + +subtest 'IO handle key files' => sub { + my $buf = 'password'; + open(my $fh, '<', \$buf) or die "open failed: $!\n"; + + my $key = File::KDBX::Key::File->new($fh); + is $key->raw_key, decode_b64('XohImNooBHFR0OVvjcYpJ3NgPQ1qq73WKhHvch0VQtg='), + 'Can calculate raw key from file handle' or diag encode_b64($key->raw_key); + is $key->type, 'hashed', 'file type is detected as hashed'; + + my ($fh_save, $filepath) = tempfile('keyfile-XXXXXX', TMPDIR => 1, UNLINK => 1, SUFFIX => '.key'); + is exception { $key->save(fh => $fh_save, type => KEY_FILE_TYPE_XML) }, undef, + 'Save key file using IO handle'; + close($fh_save); + + my $key2 = File::KDBX::Key::File->new($filepath); + is $key2->type, KEY_FILE_TYPE_XML, 'Loaded key file has the same type'; + is $key2->filepath, $filepath, 'Loaded key remembers the filepath'; + is $key2->raw_key, $key->raw_key, 'Loaded key file has the same raw key'; + $key2->reload; + is $key2->raw_key, $key->raw_key, 'Raw key is the same when reloaded same file'; + + my $easy_raw_key = "\1" x 32; + $key->init(\$easy_raw_key); + $key->save(filepath => $filepath); + + $key2->reload; + is $key2->raw_key, "\1" x 32, 'Raw key is changed after reload'; +}; + +subtest 'Key file error handling' => sub { + is exception { File::KDBX::Key::File->new }, undef, 'Cannot instantiate uninitialized'; + + like exception { File::KDBX::Key::File->init }, + qr/^Missing key primitive/, 'Throw if no primitive is provided'; + + like exception { File::KDBX::Key::File->new(testfile(qw{keys nonexistent})) }, + qr/^Failed to open key file/, 'Throw if file is missing'; + + like exception { File::KDBX::Key::File->new({}) }, + qr/^Unexpected primitive type/, 'Throw if primitive is the wrong type'; +}; + +done_testing; diff --git a/t/lib/TestCommon.pm b/t/lib/TestCommon.pm new file mode 100644 index 0000000..e499251 --- /dev/null +++ b/t/lib/TestCommon.pm @@ -0,0 +1,101 @@ +package TestCommon; + +use warnings; +use strict; + +use Data::Dumper; +use File::KDBX::Constants qw(:magic :kdf); +use File::KDBX::Util qw(can_fork dumper); +use File::Spec; +use FindBin qw($Bin); +use Test::Fatal; +use Test::Deep; + +BEGIN { + $Data::Dumper::Deepcopy = 1; + $Data::Dumper::Deparse = 1; + $Data::Dumper::Indent = 1; + $Data::Dumper::Quotekeys = 0; + $Data::Dumper::Sortkeys = 1; + $Data::Dumper::Terse = 1; + $Data::Dumper::Trailingcomma = 1; + $Data::Dumper::Useqq = 1; +} + +sub import { + my $self = shift; + my @args = @_; + + my $caller = caller; + + require Test::Warnings; + my @warnings_flags; + push @warnings_flags, ':no_end_test' if !$ENV{AUTHOR_TESTING} || grep { $_ eq ':no_warnings_test' } @args; + Test::Warnings->import(@warnings_flags); + + # Just export a random assortment of things useful for testing. + no strict 'refs'; + *{"${caller}::dumper"} = \&File::KDBX::Util::dumper; + + *{"${caller}::exception"} = \&Test::Fatal::exception; + *{"${caller}::warning"} = \&Test::Warnings::warning; + *{"${caller}::warnings"} = \&Test::Warnings::warnings; + + *{"${caller}::dump_test_deep_template"} = \&dump_test_deep_template; + *{"${caller}::ok_magic"} = \&ok_magic; + *{"${caller}::fast_kdf"} = \&fast_kdf; + *{"${caller}::can_fork"} = \&can_fork; + *{"${caller}::testfile"} = \&testfile; +} + +sub testfile { + return File::Spec->catfile($Bin, 'files', @_); +} + +sub dump_test_deep_template { + my $struct = shift; + + my $str = Dumper $struct; + # booleans: bless( do{\(my $o = 1)}, 'boolean' ) + $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/bool($1)/gs; + # objects + $str =~ s/bless\(.+?'([^']+)' \)/obj_isa('$1')/gs; + # convert two to four space indentation + $str =~ s/^( +)/' ' x (length($1) * 2)/gme; + + open(my $fh, '>>', 'TEST-DEEP-TEMPLATES.pl') or die "open failed: $!"; + print $fh $str, "\n"; +} + +sub ok_magic { + my $kdbx = shift; + my $vers = shift; + my $note = shift; + + my $magic = [$kdbx->sig1, $kdbx->sig2, $kdbx->version]; + cmp_deeply $magic, [ + KDBX_SIG1, + KDBX_SIG2_2, + $vers, + ], $note // 'KDBX magic numbers are correct'; +} + +sub fast_kdf { + my $uuid = shift // KDF_UUID_AES; + my $params = { + KDF_PARAM_UUID() => $uuid, + }; + if ($uuid eq KDF_UUID_AES || $uuid eq KDF_UUID_AES_CHALLENGE_RESPONSE) { + $params->{+KDF_PARAM_AES_ROUNDS} = 17; + $params->{+KDF_PARAM_AES_SEED} = "\1" x 32; + } + else { # Argon2 + $params->{+KDF_PARAM_ARGON2_SALT} = "\1" x 32; + $params->{+KDF_PARAM_ARGON2_PARALLELISM} = 1; + $params->{+KDF_PARAM_ARGON2_MEMORY} = 1 << 13; + $params->{+KDF_PARAM_ARGON2_ITERATIONS} = 2; + $params->{+KDF_PARAM_ARGON2_VERSION} = 0x13; + } + return $params; +} +1; diff --git a/t/memory-protection.t b/t/memory-protection.t new file mode 100644 index 0000000..328e28c --- /dev/null +++ b/t/memory-protection.t @@ -0,0 +1,305 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use Crypt::Digest qw(digest_data); +use Crypt::PRNG qw(random_bytes); +use Crypt::Misc qw(decode_b64); +use File::KDBX::Key; +use File::KDBX::Util qw(:erase :load); +use File::KDBX; +use IO::Handle; +use List::Util qw(max); +use POSIX (); +use Scalar::Util qw(looks_like_number); +use Scope::Guard; +use Test::More; + +BEGIN { + if (!$ENV{AUTHOR_TESTING}) { + plan skip_all => 'AUTHOR_TESTING required to test memory protection'; + exit; + } + if (!can_fork || !try_load_optional('POSIX::1003')) { + plan skip_all => 'fork and POSIX::1003 required to test memory protection'; + exit; + } + POSIX::1003->import(':rlimit'); +} + +my $BLOCK_SIZE = 8196; + +-e 'core' && die "Remove or move the core dump!\n"; +my $cleanup = Scope::Guard->new(sub { unlink('core') }); + +my ($cur, $max, $success) = getrlimit('RLIMIT_CORE'); +$success or die "getrlimit failed: $!\n"; +if ($cur < 1<<16) { + setrlimit('RLIMIT_CORE', RLIM_INFINITY, RLIM_INFINITY) or die "setrlimit failed: $!\n"; +} + +my $SECRET = 'c3VwZXJjYWxpZnJhZ2lsaXN0aWM='; +my $SECRET_SHA256 = 'y1cOWidI80n5EZQx24NrOiP9tlca/uNMBDLYciDyQxs='; + +for my $test ( + { + test => 'secret in scope', + run => sub { + my $secret = decode_b64($SECRET); + dump_core(); + }, + strings => [ + $SECRET => 1, + ], + }, + { + test => 'erased secret', + run => sub { + my $secret = decode_b64($SECRET); + erase $secret; + dump_core(); + }, + strings => [ + $SECRET => 0, + ], + }, + { + test => 'Key password', + run => sub { + my $password = decode_b64($SECRET); + my $key = File::KDBX::Key->new($password); + erase $password; + dump_core(); + }, + strings => [ + $SECRET => 0, + ], + }, + { + test => 'Key password, raw key shown', + run => sub { + my $password = decode_b64($SECRET); + my $key = File::KDBX::Key->new($password); + erase $password; + $key->show; + dump_core(); + }, + strings => [ + $SECRET => 0, + $SECRET_SHA256 => 1, + ], + }, + { + test => 'Key password, raw key hidden', + run => sub { + my $password = decode_b64($SECRET); + my $key = File::KDBX::Key->new($password); + erase $password; + $key->show->hide for 0..500; + dump_core(); + }, + strings => [ + $SECRET => 0, + $SECRET_SHA256 => 0, + ], + }, + { + test => 'protected strings and keys', + run => sub { + my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw'); + dump_core(); + }, + strings => [ + 'TXkgcGFzc3dvcmQgaXMgYSBzZWNyZXQgdG8gZXZlcnlvbmUu' => 0, # Password + 'QSB0cmVhc3VyZSBtYXAgaXMgb24gdGhlIGJhY2sgb2YgdGhlIERlY2xhcmF0aW9uIG9mIEluZGVwZW5kZW5jZS4=' => 0, + # Secret A: + 'SmVmZnJleSBFcHN0ZWluIGRpZG4ndCBraWxsIGhpbXNlbGYu' => 0, # Secret B + 'c3VwZXJjYWxpZnJhZ2lsaXN0aWNleHBpYWxpZG9jaW91cw==' => 1, # Nonsecret + 'SlHA3Eyhomr/UQ6vznWMRZtxlrqIm/tM3qVZv7G31DU=' => 0, # Final key + 'LuVqNfGluvLPcg2W699/Q6WGxIztX7Jvw0ONwQEi/Jc=' => 0, # Transformed key + # HMAC key: + 'kDEMVEcGR32UXTwG8j3SxsfdF+l124Ni6iHeogCWGd2z0KSG5PosDTloxC0zg7Ucn2CNR6f2wpgzcVGKmDNFCA==' => 0, + # Inner random stream key: + 'SwJSukmQdZKpHm8PywqLu1EHfUzS/gyJsg61Cm74YeRJeOpDlFblbVd5d4p+lU2/7Q28Vk4j/E2RRMC81DXdUw==' => 1, + 'RREzJd4fKHtFkjRIi+xucGPW2q+mov+LRWL4RkPql7Y=' => 1, # Random stream key (actual) + ], + }, + { + test => 'inner random stream key replaced', + run => sub { + my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw'); + $kdbx->inner_random_stream_key("\1" x 64); + dump_core(); + }, + strings => [ + # Inner random stream key: + # FIXME - there is second copy of this key somewhere... in another SvPV? + 'SwJSukmQdZKpHm8PywqLu1EHfUzS/gyJsg61Cm74YeRJeOpDlFblbVd5d4p+lU2/7Q28Vk4j/E2RRMC81DXdUw==' => undef, + ], + }, + { + test => 'protected strings revealed', + run => sub { + my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw'); + $kdbx->unlock; + dump_core(); + }, + strings => [ + 'TXkgcGFzc3dvcmQgaXMgYSBzZWNyZXQgdG8gZXZlcnlvbmUu' => 1, # Password + # Secret A: + 'QSB0cmVhc3VyZSBtYXAgaXMgb24gdGhlIGJhY2sgb2YgdGhlIERlY2xhcmF0aW9uIG9mIEluZGVwZW5kZW5jZS4=' => 1, + 'SmVmZnJleSBFcHN0ZWluIGRpZG4ndCBraWxsIGhpbXNlbGYu' => 1, # Secret B + 'c3VwZXJjYWxpZnJhZ2lsaXN0aWNleHBpYWxpZG9jaW91cw==' => 1, # Nonsecret + 'RREzJd4fKHtFkjRIi+xucGPW2q+mov+LRWL4RkPql7Y=' => 0, # Random stream key (actual) + ], + }, + { + test => 'protected strings previously-revealed', + run => sub { + my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw'); + $kdbx->unlock; + $kdbx->lock; + dump_core(); + }, + strings => [ + 'TXkgcGFzc3dvcmQgaXMgYSBzZWNyZXQgdG8gZXZlcnlvbmUu' => 0, # Password + # Secret A: + 'QSB0cmVhc3VyZSBtYXAgaXMgb24gdGhlIGJhY2sgb2YgdGhlIERlY2xhcmF0aW9uIG9mIEluZGVwZW5kZW5jZS4=' => 0, + 'SmVmZnJleSBFcHN0ZWluIGRpZG4ndCBraWxsIGhpbXNlbGYu' => 0, # Secret B + 'c3VwZXJjYWxpZnJhZ2lsaXN0aWNleHBpYWxpZG9jaW91cw==' => 1, # Nonsecret + 'RREzJd4fKHtFkjRIi+xucGPW2q+mov+LRWL4RkPql7Y=' => 0, # Random stream key (actual) + ], + }, +) { + my ($description, $run, $strings) = @$test{qw(test run strings)}; + + subtest "Dump core with $description" => sub { + my @strings = @_; + my $num_strings = @strings / 2; + plan tests => 2 + $num_strings * 2; + + my (@encoded_strings, @expected); + while (@strings) { + my ($string, $expected) = splice @strings, 0, 2; + push @encoded_strings, $string; + push @expected, $expected; + } + + my ($dumped, $has_core, @matches) = run_test($run, @encoded_strings); + + ok $dumped, 'Test process signaled that it core-dumped'; + ok $has_core, 'Found core dump' or return; + + note sprintf('core dump is %.1f MiB', (-s 'core')/1048576); + + for (my $i = 1; $i <= $num_strings; ++$i) { + my $count = $matches[$i - 1]; + my $string = $encoded_strings[$i - 1]; + my $expected = $expected[$i - 1]; + + ok defined $count, "[#$i] Got result from test environment"; + + TODO: { + local $TODO = 'Unprotected memory!' if !defined $expected; + if ($expected) { + ok 0 < $count, "[#$i] String FOUND" + or diag "Found $count copies of string #$i\nString: $string"; + } + else { + is $count, 0, "[#$i] String MISSING" + or diag "Found $count copies of string #$i\nString: $string"; + } + } + } + }, @$strings; +} + +done_testing; +exit; + +############################################################################## + +sub dump_core { kill 'QUIT', $$ } + +sub file_grep { + my $filepath = shift; + my @strings = @_; + + my $counter = 0; + my %counts = map { $_ => $counter++ } @strings; + my @counts = map { 0 } @strings; + + my $pattern = join('|', map { quotemeta($_) } @strings); + + my $overlap = (max map { length } @strings) - 1; + + open(my $fh, '<:raw', $filepath) or die "open failed: $!\n"; + + my $previous; + while (read $fh, my $block, $BLOCK_SIZE) { + substr($block, 0, 0, substr($previous, -$overlap)) if defined $previous; + + while ($block =~ /($pattern)/gs) { + ++$counts[$counts{$1}]; + } + $previous = substr($block, $overlap); + } + die "read error: $!" if $fh->error; + + return @counts; +} + +sub run_test { + my $code = shift; + my @strings = @_; + + my $seed = random_bytes(32); + + pipe(my $read, my $write) or die "pipe failed: $!\n"; + + defined(my $pid = fork) or die "fork failed: $!\n"; + if (!$pid) { # child + close($read); + + my $exit_status = run_doomed_child($code, $seed); + my $dumped = $exit_status & 127 && $exit_status & 128; + + my @decoded_strings = map { decode_b64($_) } @strings; + + my @matches = file_grep('core', @decoded_strings); + print $write join('|', $dumped, -f 'core' ? 1 : 0, @matches); + close($write); + + POSIX::_exit(0); + } + + close($write); + my $results = do { local $/; <$read> }; + + waitpid($pid, 0); + my $exit_status = $? >> 8; + $exit_status == 0 or die "test environment exited non-zero: $exit_status\n"; + + return split(/\|/, $results); +} + +sub run_doomed_child { + my $code = shift; + my $seed = shift; + + unlink('core') or die "unlink failed: $!\n" if -f 'core'; + + defined(my $pid = fork) or die "fork failed: $!\n"; + if (!$pid) { # child + $code->(); + dump_core(); # doomed + POSIX::_exit(1); # paranoid + } + + waitpid($pid, 0); + return $?; +} diff --git a/t/object.t b/t/object.t new file mode 100644 index 0000000..d3e766d --- /dev/null +++ b/t/object.t @@ -0,0 +1,179 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Entry; +use File::KDBX::Util qw(:uuid); +use File::KDBX; +use Test::Deep; +use Test::More; + +subtest 'Cloning' => sub { + my $kdbx = File::KDBX->new; + my $entry = File::KDBX::Entry->new; + + my $copy = $entry->clone; + like exception { $copy->kdbx }, qr/disconnected/, 'Disconnected entry copy is also disconnectedisconnected'; + cmp_deeply $copy, $entry, 'Disconnected entry and its clone are identical'; + + $entry->kdbx($kdbx); + $copy = $entry->clone; + is $entry->kdbx, $copy->kdbx, 'Connected entry copy is also connected'; + cmp_deeply $copy, $entry, 'Connected entry and its clone are identical'; + + my $txn = $entry->begin_work; + $entry->title('foo'); + $entry->username('bar'); + $entry->password('baz'); + $txn->commit; + + $copy = $entry->clone; + is @{$copy->history}, 1, 'Copy has a historical entry' or dumper $copy->history; + cmp_deeply $copy, $entry, 'Entry with history and its clone are identical'; + + $copy = $entry->clone(history => 0); + is @{$copy->history}, 0, 'Copy excluding history has no history'; + + $copy = $entry->clone(new_uuid => 1); + isnt $copy->uuid, $entry->uuid, 'Entry copy with new UUID has a different UUID'; + + $copy = $entry->clone(reference_username => 1); + my $ref = sprintf('{REF:U@I:%s}', format_uuid($entry->uuid)); + is $copy->username, $ref, 'Copy has username reference'; + is $copy->expand_username, $ref, 'Entry copy does not expand username because entry is not in database'; + + my $group = $kdbx->add_group(label => 'Passwords'); + $group->add_entry($entry); + is $copy->expand_username, $entry->username, + 'Entry in database and its copy with username ref have same expanded username'; + + $copy = $entry->clone; + is $kdbx->entries->size, 1, 'Still only one entry after cloning'; + + $copy = $entry->clone(parent => 1); + is $kdbx->entries->size, 2, 'New copy added to database if clone with parent option'; + my ($e1, $e2) = $kdbx->entries->each; + isnt $e1, $e2, 'Entry and its copy in the database are different objects'; + is $e1->title, $e2->title, 'Entry copy has the same title as the original entry'; + + $copy = $entry->clone(parent => 1, relabel => 1); + is $kdbx->entries->size, 3, 'New copy added to database if clone with parent option'; + my $e3 = $kdbx->entries->skip(2)->next; + is $e3, $copy, 'New copy and new entry in the database match'; + is $e3->title, 'foo - Copy', 'New copy has a modified title'; + + $copy = $group->clone; + cmp_deeply $copy, $group, 'Group and its clone are identical'; + is @{$copy->entries}, 3, 'Group copy has as many entries as the original'; + is @{$copy->entries->[0]->history}, 1, 'Entry in group copy has history'; + + $copy = $group->clone(history => 0); + is @{$copy->entries}, 3, 'Group copy without history has as many entries as the original'; + is @{$copy->entries->[0]->history}, 0, 'Entry in group copy has no history'; + + $copy = $group->clone(entries => 0); + is @{$copy->entries}, 0, 'Group copy without entries has no entries'; + is $copy->name, 'Passwords', 'Group copy label is the same as the original'; + + $copy = $group->clone(relabel => 1); + is $copy->name, 'Passwords - Copy', 'Group copy relabeled from the original title'; + is $kdbx->entries->size, 3, 'No new entries were added to the database'; + + $copy = $group->clone(relabel => 1, parent => 1); + is $kdbx->entries->size, 6, 'Copy a group within parent doubles the number of entries in the database'; + isnt $group->entries->[0]->uuid, $copy->entries->[0]->uuid, + 'First entry in group and its copy are different'; +}; + +subtest 'Transactions' => sub { + my $kdbx = File::KDBX->new; + + my $root = $kdbx->root; + my $entry = $kdbx->add_entry( + label => 'One', + last_modification_time => Time::Piece->strptime('2022-04-20', '%Y-%m-%d'), + username => 'Fred', + ); + + my $txn = $root->begin_work; + $root->label('Toor'); + $root->notes(''); + $txn->commit; + is $root->label, 'Toor', 'Retain change to root label after commit'; + + $root->begin_work; + $root->label('Root'); + $entry->label('Zap'); + $root->rollback; + is $root->label, 'Toor', 'Undo change to root label after rollback'; + is $entry->label, 'Zap', 'Retain change to entry after rollback'; + + $txn = $root->begin_work(entries => 1); + $root->label('Root'); + $entry->label('Zippy'); + undef $txn; # implicit rollback + is $root->label, 'Toor', 'Undo change to root label after implicit rollback'; + is $entry->label, 'Zap', 'Undo change to entry after rollback with deep transaction'; + + $txn = $entry->begin_work; + my $mtime = $entry->last_modification_time; + my $username = $entry->string('UserName'); + $username->{meh} = 'hi'; + $entry->username('jinx'); + $txn->rollback; + is $entry->string('UserName'), $username, 'Rollback keeps original references'; + is $entry->last_modification_time, $mtime, 'No last modification time change after rollback'; + + $txn = $entry->begin_work; + $entry->username('jinx'); + $txn->commit; + isnt $entry->last_modification_time, $mtime, 'Last modification time changes after commit'; + + { + my $txn1 = $root->begin_work; + $root->label('alien'); + { + my $txn2 = $root->begin_work; + $root->label('truth'); + $txn2->commit; + } + } + is $root->label, 'Toor', 'Changes thrown away after rolling back outer transaction'; + + { + my $txn1 = $root->begin_work; + $root->label('alien'); + { + my $txn2 = $root->begin_work; + $root->label('truth'); + } + $txn1->commit; + } + is $root->label, 'alien', 'Keep committed change after rolling back inner transaction'; + + { + my $txn1 = $root->begin_work; + $root->label('alien'); + { + my $txn2 = $root->begin_work; + $root->label('truth'); + $txn2->commit; + } + $txn1->commit; + } + is $root->label, 'truth', 'Keep committed change from inner transaction'; + + $txn = $root->begin_work; + $root->label('Lalala'); + my $dump = $kdbx->dump_string('a'); + $txn->commit; + is $root->label, 'Lalala', 'Keep committed label change after dump'; + my $load = File::KDBX->load_string($dump, 'a'); + is $load->root->label, 'truth', 'Object dumped before committing matches the pre-transaction state'; +}; + +done_testing; diff --git a/t/otp.t b/t/otp.t new file mode 100644 index 0000000..25d2fd9 --- /dev/null +++ b/t/otp.t @@ -0,0 +1,165 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Entry; +use Test::More; + +eval { require Pass::OTP } or plan skip_all => 'Pass::OTP required to test one-time-passwords'; + +my $secret_txt = 'hello'; +my $secret_b32 = 'NBSWY3DP'; +my $secret_b64 = 'aGVsbG8='; +my $secret_hex = '68656c6c6f'; +my $when = 1655488780; + +for my $test ( + { + name => 'HOTP - Basic', + input => {otp => "otpauth://hotp/Issuer:user?secret=${secret_b32}&issuer=Issuer"}, + codes => [qw(029578 825147 676217)], + uri => 'otpauth://hotp/Issuer:user?secret=NBSWY3DP&issuer=Issuer', + }, + { + name => 'HOTP - Start from 42', + input => { + otp => "otpauth://hotp/Issuer:user?secret=${secret_b32}&issuer=Issuer", + 'HmacOtp-Counter' => 42, + }, + codes => [qw(528783 171971 115730)], + uri => 'otpauth://hotp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&counter=42', + }, + { + name => 'HOTP - 7 digits', + input => {otp => "otpauth://hotp/Issuer:user?secret=${secret_b32}&issuer=Issuer&digits=7"}, + codes => [qw(3029578 9825147 9676217)], + uri => 'otpauth://hotp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&digits=7', + }, + { + name => 'HOTP - KeePass 2 storage (Base32)', + input => {'HmacOtp-Secret-Base32' => $secret_b32}, + codes => [qw(029578 825147 676217)], + uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX', + }, + { + name => 'HOTP - KeePass 2 storage (Base64)', + input => {'HmacOtp-Secret-Base64' => $secret_b64}, + codes => [qw(029578 825147 676217)], + uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX', + }, + { + name => 'HOTP - KeePass 2 storage (Hex)', + input => {'HmacOtp-Secret-Hex' => $secret_hex}, + codes => [qw(029578 825147 676217)], + uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX', + }, + { + name => 'HOTP - KeePass 2 storage (Text)', + input => {'HmacOtp-Secret' => $secret_txt}, + codes => [qw(029578 825147 676217)], + uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX', + }, + { + name => 'HOTP - KeePass 2, start from 42', + input => {'HmacOtp-Secret' => $secret_txt, 'HmacOtp-Counter' => 42}, + codes => [qw(528783 171971 115730)], + uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX&counter=42', + }, + { + name => 'HOTP - Non-default attributes', + input => {'HmacOtp-Secret' => $secret_txt, Title => 'Website', UserName => 'foo!?'}, + codes => [qw(029578 825147 676217)], + uri => 'otpauth://hotp/Website:foo%21%3F?secret=NBSWY3DP&issuer=Website', + }, +) { + my $entry = File::KDBX::Entry->new; + $entry->string($_ => $test->{input}{$_}) for keys %{$test->{input}}; + is $entry->hmac_otp_uri, $test->{uri}, "$test->{name}: Valid URI"; + for my $code (@{$test->{codes}}) { + my $counter = $entry->string_value('HmacOtp-Counter') || 'undef'; + is $entry->hmac_otp, $code, "$test->{name}: Valid OTP ($counter)"; + } +} + +for my $test ( + { + name => 'TOTP - Basic', + input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&period=30&digits=6&issuer=Issuer"}, + code => '875357', + uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer', + }, + { + name => 'TOTP - SHA256', + input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&period=30&algorithm=SHA256"}, + code => '630489', + uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&algorithm=SHA256', + }, + { + name => 'TOTP - 60s period', + input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&period=60&digits=6&issuer=Issuer"}, + code => '647601', + uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&period=60', + }, + { + name => 'TOTP - 7 digits', + input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&period=30&digits=7&issuer=Issuer"}, + code => '9875357', + uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&digits=7', + }, + { + name => 'TOTP - Steam', + input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&issuer=Issuer&encoder=steam"}, + code => '55YH2', + uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&encoder=steam', + }, + { + name => 'TOTP - KeePass 2 storage', + input => {'TimeOtp-Secret-Base32' => $secret_b32}, + code => '875357', + uri => 'otpauth://totp/KDBX:none?secret=NBSWY3DP&issuer=KDBX', + }, + { + name => 'TOTP - KeePass 2 storage, SHA256', + input => {'TimeOtp-Secret-Base32' => $secret_b32, 'TimeOtp-Algorithm' => 'HMAC-SHA-256'}, + code => '630489', + uri => 'otpauth://totp/KDBX:none?secret=NBSWY3DP&issuer=KDBX&algorithm=SHA256', + }, + { + name => 'TOTP - KeePass 2 storage, 60s period', + input => {'TimeOtp-Secret-Base32' => $secret_b32, 'TimeOtp-Period' => '60'}, + code => '647601', + uri => 'otpauth://totp/KDBX:none?secret=NBSWY3DP&issuer=KDBX&period=60', + }, + { + name => 'TOTP - KeePass 2 storage, 7 digits', + input => {'TimeOtp-Secret-Base32' => $secret_b32, 'TimeOtp-Length' => '7'}, + code => '9875357', + uri => 'otpauth://totp/KDBX:none?secret=NBSWY3DP&issuer=KDBX&digits=7', + }, + { + name => 'TOTP - Non-default attributes', + input => {'TimeOtp-Secret-Base32' => $secret_b32, Title => 'Website', UserName => 'foo!?'}, + code => '875357', + uri => 'otpauth://totp/Website:foo%21%3F?secret=NBSWY3DP&issuer=Website', + }, +) { + my $entry = File::KDBX::Entry->new; + $entry->string($_ => $test->{input}{$_}) for keys %{$test->{input}}; + is $entry->time_otp_uri, $test->{uri}, "$test->{name}: Valid URI"; + is $entry->time_otp(now => $when), $test->{code}, "$test->{name}: Valid OTP"; +} + +{ + my $entry = File::KDBX::Entry->new; + $entry->string('TimeOtp-Secret-Base32' => $secret_b32); + $entry->string('TimeOtp-Secret' => 'wat'); + my $warning = warning { $entry->time_otp_uri }; + like $warning, qr/Found multiple/, 'Alert if redundant secrets' + or diag 'Warnings: ', explain $warning; +} + +done_testing; diff --git a/t/placeholders.t b/t/placeholders.t new file mode 100644 index 0000000..8874481 --- /dev/null +++ b/t/placeholders.t @@ -0,0 +1,77 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Entry; +use File::KDBX; +use Test::More; + +my $kdbx = File::KDBX->new; + +my $entry1 = $kdbx->add_entry( + title => 'Foo', + username => 'User {TITLE}', +); +my $entry2 = $kdbx->add_entry( + title => 'Bar', + username => sprintf('{REF:U@I:%s}', $entry1->id), + notes => 'notes {URL}', + url => 'url {NOTES}', +); +my $entry3 = $kdbx->add_entry( + username => sprintf('{REF:U@I:%s}', $entry2->id), + password => 'lyric:%LYRIC%', + notes => '%MISSING% %% %NOT AVAR% %LYRIC%', +); + +is $entry1->expand_username, 'User Foo', 'Basic placeholder expansion'; +is $entry2->expand_username, 'User Foo', 'Reference to another entry'; +is $entry3->expand_username, 'User Foo', 'Reference to another entry through another'; + +my $recursive_expected = 'url notes ' x 10 . 'url {NOTES}'; +my $recursive; +my $warning = warning { $recursive = $entry2->expand_url }; +like $warning, qr/detected deep recursion/i, 'Deep recursion causes a warning' + or diag 'Warnings: ', explain $warning; +is $recursive, $recursive_expected, 'Recursive placeholders resolve to... something'; + +{ + my $entry = File::KDBX::Entry->new(url => 'http://example.com?{EXPLODE}'); + is $entry->expand_url, 'http://example.com?{EXPLODE}', + 'Unhandled placeholders are not replaced'; + + local $File::KDBX::PLACEHOLDERS{EXPLODE} = sub { 'boom' }; + is $entry->expand_url, 'http://example.com?boom', 'Custom placeholders can be set'; + + $entry->url('{eXplOde}!!'); + is $entry->expand_url, 'boom!!', 'Placeholder tags are match case-insensitively'; +} + +{ + local $ENV{LYRIC} = 'I am the very model of a modern Major-General'; + is $entry3->expand_password, "lyric:$ENV{LYRIC}", 'Environment variable placeholders'; + is $entry3->expand_notes, qq{%MISSING% %% %NOT AVAR% $ENV{LYRIC}}, + 'Do not replace things that look like environment variables but are not'; +} + +{ + my $counter = 0; + local $File::KDBX::PLACEHOLDERS{'COUNTER'} = $File::KDBX::PLACEHOLDERS{'COUNTER:'} = sub { + (undef, my $arg) = @_; + return defined $arg ? $arg : ++$counter; + }; + my $entry4 = $kdbx->add_entry( + url => '{COUNTER} {USERNAME}', + username => '{COUNTER}x{COUNTER}y{COUNTER:-1}', + ); + like $entry4->expand_username, qr/^1x1y-1$/, + 'Each unique placeholder is evaluated once'; + like $entry4->expand_url, qr/^2 3x3y-1$/, + 'Each unique placeholder is evaluated once per string'; +} + +done_testing; diff --git a/t/query.t b/t/query.t new file mode 100644 index 0000000..c15a009 --- /dev/null +++ b/t/query.t @@ -0,0 +1,217 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Util qw(query search simple_expression_query); +use Test::Deep; +use Test::More; + +my $list = [ + { + id => 1, + name => 'Bob', + age => 34, + married => 1, + notes => 'Enjoys bowling on Thursdays', + }, + { + id => 2, + name => 'Ken', + age => 17, + married => 0, + notes => 'Eats dessert first', + color => '', + }, + { + id => 3, + name => 'Becky', + age => 25, + married => 1, + notes => 'Listens to rap music on repeat', + color => 'orange', + }, + { + id => 4, + name => 'Bobby', + age => 5, + notes => 'Loves candy and running around like a crazy person', + color => 'blue', + }, +]; + +subtest 'Declarative structure' => sub { + my $result = search($list, name => 'Bob'); + cmp_deeply $result, [shallow($list->[0])], 'Find Bob' + or diag explain $result; + + $result = search($list, name => 'Ken'); + cmp_deeply $result, [$list->[1]], 'Find Ken' + or diag explain $result; + + $result = search($list, age => 25); + cmp_deeply $result, [$list->[2]], 'Find Becky by age' + or diag explain $result; + + $result = search($list, {name => 'Becky', age => 25}); + cmp_deeply $result, [$list->[2]], 'Find Becky by name AND age' + or diag explain $result; + + $result = search($list, {name => 'Becky', age => 99}); + cmp_deeply $result, [], 'Miss Becky with wrong age' + or diag explain $result; + + $result = search($list, [name => 'Becky', age => 17]); + cmp_deeply $result, [$list->[1], $list->[2]], 'Find Ken and Becky with different criteria' + or diag explain $result; + + $result = search($list, name => 'Becky', age => 17); + cmp_deeply $result, [$list->[1], $list->[2]], 'Query list defaults to OR logic' + or diag explain $result; + + $result = search($list, age => {'>=', 18}); + cmp_deeply $result, [$list->[0], $list->[2]], 'Find adults' + or diag explain $result; + + $result = search($list, name => {'=~', qr/^Bob/}); + cmp_deeply $result, [$list->[0], $list->[3]], 'Find both Bobs' + or diag explain $result; + + $result = search($list, -and => [name => 'Becky', age => 99]); + cmp_deeply $result, [], 'Specify AND logic explicitly' + or diag explain $result; + + $result = search($list, {name => 'Becky', age => 99}); + cmp_deeply $result, [], 'Specify AND logic implicitly' + or diag explain $result; + + $result = search($list, '!' => 'married'); + cmp_deeply $result, [$list->[1], $list->[3]], 'Find unmarried (using normal operator)' + or diag explain $result; + + $result = search($list, -false => 'married'); + cmp_deeply $result, [$list->[1], $list->[3]], 'Find unmarried (using special operator)' + or diag explain $result; + + $result = search($list, -true => 'married'); + cmp_deeply $result, [$list->[0], $list->[2]], 'Find married persons (using special operator)' + or diag explain $result; + + $result = search($list, -not => {name => {'=~', qr/^Bob/}}); + cmp_deeply $result, [$list->[1], $list->[2]], 'What about Bob? Inverse a complex query' + or diag explain $result; + + $result = search($list, -nonempty => 'color'); + cmp_deeply $result, [$list->[2], $list->[3]], 'Find the colorful' + or diag explain $result; + + $result = search($list, color => {ne => undef}); + cmp_deeply $result, [$list->[2], $list->[3]], 'Find the colorful (compare to undef)' + or diag explain $result; + + $result = search($list, -empty => 'color'); + cmp_deeply $result, [$list->[0], $list->[1]], 'Find those without color' + or diag explain $result; + + $result = search($list, color => {eq => undef}); + cmp_deeply $result, [$list->[0], $list->[1]], 'Find those without color (compare to undef)' + or diag explain $result; + + $result = search($list, -defined => 'color'); + cmp_deeply $result, [$list->[1], $list->[2], $list->[3]], 'Find defined colors' + or diag explain $result; + + $result = search($list, -undef => 'color'); + cmp_deeply $result, [$list->[0]], 'Find undefined colors' + or diag explain $result; + + $result = search($list, + -and => [ + name => {'=~', qr/^Bob/}, + -and => { + name => {'ne', 'Bob'}, + }, + ], + -not => {'!' => 'Bobby'}, + ); + cmp_deeply $result, [$list->[3]], 'Complex query' + or diag explain $result; + + my $query = query(name => 'Ken'); + $result = search($list, $query); + cmp_deeply $result, [$list->[1]], 'Search using a pre-compiled query' + or diag explain $result; + + my $custom_query = sub { shift->{name} eq 'Bobby' }; + $result = search($list, $custom_query); + cmp_deeply $result, [$list->[3]], 'Search using a custom query subroutine' + or diag explain $result; +}; + +############################################################################## + +subtest 'Simple expressions' => sub { + my $simple_query = simple_expression_query('bob', qw{name notes}); + my $result = search($list, $simple_query); + cmp_deeply $result, [$list->[0], $list->[3]], 'Basic one-term expression' + or diag explain $result; + + $result = search($list, \'bob', qw{name notes}); + cmp_deeply $result, [$list->[0], $list->[3]], 'Basic one-term expression on search' + or diag explain $result; + + $simple_query = simple_expression_query(' Dessert ', qw{notes}); + $result = search($list, $simple_query); + cmp_deeply $result, [$list->[1]], 'Whitespace is ignored' + or diag explain $result; + + $simple_query = simple_expression_query('to music', qw{notes}); + $result = search($list, $simple_query); + cmp_deeply $result, [$list->[2]], 'Multiple terms' + or diag explain $result; + + $simple_query = simple_expression_query('"to music"', qw{notes}); + $result = search($list, $simple_query); + cmp_deeply $result, [], 'One quoted term' + or diag explain $result; + + $simple_query = simple_expression_query('candy "CRAZY PERSON" ', qw{notes}); + $result = search($list, $simple_query); + cmp_deeply $result, [$list->[3]], 'Multiple terms, one quoted term' + or diag explain $result; + + $simple_query = simple_expression_query(" bob\tcandy\n\n", qw{name notes}); + $result = search($list, $simple_query); + cmp_deeply $result, [$list->[3]], 'Multiple terms in different fields' + or diag explain $result; + + $simple_query = simple_expression_query('music -repeat', qw{notes}); + $result = search($list, $simple_query); + cmp_deeply $result, [], 'Multiple terms, one negative term' + or diag explain $result; + + $simple_query = simple_expression_query('-bob', qw{name}); + $result = search($list, $simple_query); + cmp_deeply $result, [$list->[1], $list->[2]], 'Negative term' + or diag explain $result; + + $simple_query = simple_expression_query('bob -bobby', qw{name}); + $result = search($list, $simple_query); + cmp_deeply $result, [$list->[0]], 'Multiple mixed terms' + or diag explain $result; + + $simple_query = simple_expression_query(25, '==', qw{age}); + $result = search($list, $simple_query); + cmp_deeply $result, [$list->[2]], 'Custom operator' + or diag explain $result; + + $simple_query = simple_expression_query('-25', '==', qw{age}); + $result = search($list, $simple_query); + cmp_deeply $result, [$list->[0], $list->[1], $list->[3]], 'Negative term, custom operator' + or diag explain $result; +}; + +done_testing; diff --git a/t/references.t b/t/references.t new file mode 100644 index 0000000..9b31cfa --- /dev/null +++ b/t/references.t @@ -0,0 +1,52 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX; +use Test::More; + +my $kdbx = File::KDBX->new; +my $entry1 = $kdbx->add_entry( + title => 'Sun Valley Bank Inc.', + username => 'fred', + password => 'secr3t', +); +my $entry2 = $kdbx->add_entry( + title => 'Donut Shoppe', + username => 'freddy', + password => '1234', + testcustom => 'a custom string', +); +my $entry3 = $kdbx->add_entry( + title => 'Sun Clinic Inc.', + username => 'jerry', + password => 'password', + mycustom => 'this is another custom string', +); + +for my $test ( + ['{REF:U@T:donut}', 'freddy'], + ['U@T:donut', 'freddy'], + [[U => T => 'donut'], 'freddy', 'A reference can be pre-parsed parameters'], + + ['{REF:U@T:sun inc}', 'fred'], + ['{REF:U@T:"Sun Clinic Inc."}', 'jerry'], + + ['{REF:U@I:' . $entry2->id . '}', 'freddy', 'Resolve a field by UUID'], + + ['{REF:U@O:custom}', 'freddy'], + ['{REF:U@O:"another custom"}', 'jerry'], + + ['{REF:U@T:donut meh}', undef], + ['{REF:O@U:freddy}', undef], +) { + my ($ref, $expected, $note) = @$test; + $note //= "Reference: $ref"; + is $kdbx->resolve_reference(ref $ref eq 'ARRAY' ? @$ref : $ref), $expected, $note; +} + +done_testing; diff --git a/t/safe.t b/t/safe.t new file mode 100644 index 0000000..efcf31f --- /dev/null +++ b/t/safe.t @@ -0,0 +1,62 @@ +#!/usr/bin/env perl + +use utf8; +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Safe; +use Test::Deep; +use Test::More; + +my $secret = 'secret'; + +my @strings = ( + { + value => 'classified', + }, + { + value => 'bar', + meh => 'ignored', + }, + { + value => '你好', + }, +); + +my $safe = File::KDBX::Safe->new([@strings, \$secret]); +cmp_deeply \@strings, [ + { + value => undef, + }, + { + value => undef, + meh => 'ignored', + }, + { + value => undef, + }, +], 'Encrypt strings in a safe' or diag explain \@strings; +is $secret, undef, 'Scalar was set to undef'; + +my $val = $safe->peek($strings[1]); +is $val, 'bar', 'Peek at a string'; + +$safe->unlock; +cmp_deeply \@strings, [ + { + value => 'classified', + }, + { + value => 'bar', + meh => 'ignored', + }, + { + value => '你好', + }, +], 'Decrypt strings in a safe' or diag explain \@strings; +is $secret, 'secret', 'Scalar was set back to secret'; + +done_testing; diff --git a/t/util.t b/t/util.t new file mode 100644 index 0000000..5ea4359 --- /dev/null +++ b/t/util.t @@ -0,0 +1,135 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use File::KDBX::Util qw(:all); +use Test::More; + +can_ok('File::KDBX::Util', qw{ + assert_64bit + can_fork + dumper + empty + erase + erase_scoped + format_uuid + generate_uuid + gunzip + gzip + load_optional + nonempty + pad_pkcs7 + query + search + simple_expression_query + snakify + split_url + trim + uri_escape_utf8 + uri_unescape_utf8 + uuid +}); + +subtest 'Emptiness' => sub { + my @empty; + my @nonempty = 0; + ok empty(@empty), 'Empty array should be empty'; + ok !nonempty(@empty), 'Empty array should be !nonempty'; + ok !empty(@nonempty), 'Array should be !empty'; + ok nonempty(@nonempty), 'Array should be nonempty'; + + my %empty; + my %nonempty = (a => 'b'); + ok empty(%empty), 'Empty hash should be empty'; + ok !nonempty(%empty), 'Empty hash should be !nonempty'; + ok !empty(%nonempty), 'Hash should be !empty'; + ok nonempty(%nonempty), 'Hash should be nonempty'; + + my $empty = ''; + my $nonempty = '0'; + my $eref1 = \$empty; + my $eref2 = \$eref1; + my $nref1 = \$nonempty; + my $nref2 = \$nref1; + + for my $test ( + [0, $empty, 'Empty string'], + [0, undef, 'Undef'], + [0, \undef, 'Reference to undef'], + [0, {}, 'Empty hashref'], + [0, [], 'Empty arrayref'], + [0, $eref1, 'Reference to empty string'], + [0, $eref2, 'Reference to reference to empty string'], + [0, \\\\\\\'', 'Deep reference to empty string'], + [1, $nonempty, 'String'], + [1, 'hi', 'String'], + [1, 1, 'Number'], + [1, 0, 'Zero'], + [1, {a => 'b'}, 'Hashref'], + [1, [0], 'Arrayref'], + [1, $nref1, 'Reference to string'], + [1, $nref2, 'Reference to reference to string'], + [1, \\\\\\\'z', 'Deep reference to string'], + ) { + my ($expected, $thing, $note) = @$test; + if ($expected) { + ok !empty($thing), "$note should be !empty"; + ok nonempty($thing), "$note should be nonempty"; + } + else { + ok empty($thing), "$note should be empty"; + ok !nonempty($thing), "$note should be !nonempty"; + } + } +}; + +subtest 'UUIDs' => sub { + my $uuid = "\x01\x23\x45\x67\x89\xab\xcd\xef\x01\x23\x45\x67\x89\xab\xcd\xef"; + my $uuid1 = uuid('01234567-89AB-CDEF-0123-456789ABCDEF'); + my $uuid2 = uuid('0123456789ABCDEF0123456789ABCDEF'); + my $uuid3 = uuid('012-3-4-56-789AB-CDEF---012-34567-89ABC-DEF'); + + is $uuid1, $uuid, 'Formatted UUID is packed'; + is $uuid2, $uuid, 'Formatted UUID does not need dashes'; + is $uuid2, $uuid, 'Formatted UUID can have weird dashes'; + + is format_uuid($uuid), '0123456789ABCDEF0123456789ABCDEF', 'UUID unpacks to hex string'; + is format_uuid($uuid, '-'), '01234567-89AB-CDEF-0123-456789ABCDEF', 'Formatted UUID can be delimited'; + + my %uuid_set = ($uuid => 'whatever'); + + my $new_uuid = generate_uuid(\%uuid_set); + isnt $new_uuid, $uuid, 'Generated UUID is not in set'; + + $new_uuid = generate_uuid(sub { !$uuid_set{$_} }); + isnt $new_uuid, $uuid, 'Generated UUID passes a test function'; + + like generate_uuid(print => 1), qr/^[A-Za-z0-9]+$/, 'Printable UUID is printable (1)'; + like generate_uuid(printable => 1), qr/^[A-Za-z0-9]+$/, 'Printable UUID is printable (2)'; +}; + +subtest 'Snakification' => sub { + is snakify('FooBar'), 'foo_bar', 'Basic snakification'; + is snakify('MyUUIDSet'), 'my_uuid_set', 'Acronym snakification'; + is snakify('Numbers123'), 'numbers_123', 'Snake case with numbers'; + is snakify('456Baz'), '456_baz', 'Prefixed numbers'; +}; + +subtest 'Padding' => sub { + plan tests => 8; + + is pad_pkcs7('foo', 2), "foo\x01", 'Pad one byte to fill the second block'; + is pad_pkcs7('foo', 4), "foo\x01", 'Pad one byte to fill one block'; + is pad_pkcs7('foo', 8), "foo\x05\x05\x05\x05\x05", 'Pad to fill one block'; + is pad_pkcs7('moof', 4), "moof\x04\x04\x04\x04", 'Add a whole block of padding'; + is pad_pkcs7('', 3), "\x03\x03\x03", 'Pad an empty string'; + like exception { pad_pkcs7(undef, 8) }, qr/must provide a string/i, 'String must be defined'; + like exception { pad_pkcs7('bar') }, qr/must provide block size/i, 'Size must defined'; + like exception { pad_pkcs7('bar', 0) }, qr/must provide block size/i, 'Size must be non-zero'; +}; + +done_testing; diff --git a/t/yubikey.t b/t/yubikey.t new file mode 100644 index 0000000..b325b25 --- /dev/null +++ b/t/yubikey.t @@ -0,0 +1,87 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use lib 't/lib'; +use TestCommon; + +use Config; +use File::KDBX::Key::YubiKey; +use Test::More; + +$^O eq 'MSWin32' and plan skip_all => 'Non-Windows required to test YubiKeys'; + +@ENV{qw(YKCHALRESP YKCHALRESP_FLAGS)} = ($Config{perlpath}, testfile(qw{bin ykchalresp})); +@ENV{qw(YKINFO YKINFO_FLAGS)} = ($Config{perlpath}, testfile(qw{bin ykinfo})); + +{ + my ($pre, $post); + my $key = File::KDBX::Key::YubiKey->new( + pre_challenge => sub { ++$pre }, + post_challenge => sub { ++$post }, + ); + my $resp; + is exception { $resp = $key->challenge('foo') }, undef, 'Do not throw during non-blocking response'; + is $resp, "\xf0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", 'Get a non-blocking challenge response'; + is length($resp), 20, 'Response is the proper length'; + is $pre, 1, 'The pre-challenge callback is called'; + is $post, 1, 'The post-challenge callback is called'; +} + +{ + my $key = File::KDBX::Key::YubiKey->new; + local $ENV{YKCHALRESP_MOCK} = 'error'; + like exception { $key->challenge('foo') }, qr/Yubikey core error:/i, + 'Throw if challenge-response program errored out'; +} + +{ + my $key = File::KDBX::Key::YubiKey->new; + local $ENV{YKCHALRESP_MOCK} = 'usberror'; + like exception { $key->challenge('foo') }, qr/USB error:/i, + 'Throw if challenge-response program had a USB error'; +} + +{ + my $key = File::KDBX::Key::YubiKey->new(timeout => 0, device => 3, slot => 2); + local $ENV{YKCHALRESP_MOCK} = 'block'; + + like exception { $key->challenge('foo') }, qr/operation would block/i, + 'Throw if challenge would block but we do not want to wait'; + + $key->timeout(1); + like exception { $key->challenge('foo') }, qr/timed out/i, + 'Timeout while waiting for response'; + + $key->timeout(-1); + my $resp; + is exception { $resp = $key->challenge('foo') }, undef, + 'Do not throw during blocking response'; + is $resp, "\xf0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", 'Get a blocking challenge response'; +} + +{ + my $key = File::KDBX::Key::YubiKey->new(device => 0, slot => 1); + is $key->name, 'YubiKey NEO FIDO v2.0.0 [123] (slot #1)', + 'Get name for a new, unscanned key'; + is $key->serial, 123, 'Get the serial number of the new key'; +} + +{ + my ($key, @other) = File::KDBX::Key::YubiKey->scan; + is $key->name, 'YubiKey 4/5 OTP v3.0.1 [456] (slot #2)', + 'Find expected YubiKey'; + is $key->serial, 456, 'Get the serial number of the scanned key'; + is scalar @other, 0, 'Do not find any other YubiKeys'; +} + +{ + local $ENV{YKCHALRESP} = testfile(qw{bin nonexistent}); + local $ENV{YKCHALRESP_FLAGS} = undef; + my $key = File::KDBX::Key::YubiKey->new; + like exception { $key->challenge('foo') }, qr/failed to run|failed to receive challenge response/i, + 'Throw if the program failed to run'; +} + +done_testing; diff --git a/xt/author/clean-namespaces.t b/xt/author/clean-namespaces.t new file mode 100644 index 0000000..2036430 --- /dev/null +++ b/xt/author/clean-namespaces.t @@ -0,0 +1,16 @@ +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::CleanNamespaces 0.006 + +use Test::More 0.94; +use Test::CleanNamespaces 0.15; + +subtest all_namespaces_clean => sub { + namespaces_clean( + grep { my $mod = $_; not grep { $mod =~ $_ } qr/::Util|::KDF::AES$/ } + Test::CleanNamespaces->find_modules + ); +}; + +done_testing; diff --git a/xt/author/critic.t b/xt/author/critic.t new file mode 100644 index 0000000..80ccdad --- /dev/null +++ b/xt/author/critic.t @@ -0,0 +1,7 @@ +#!perl + +use strict; +use warnings; + +use Test::Perl::Critic (-profile => "perlcritic.rc") x!! -e "perlcritic.rc"; +all_critic_ok(); diff --git a/xt/author/distmeta.t b/xt/author/distmeta.t new file mode 100644 index 0000000..c2280dc --- /dev/null +++ b/xt/author/distmeta.t @@ -0,0 +1,6 @@ +#!perl +# This file was automatically generated by Dist::Zilla::Plugin::MetaTests. + +use Test::CPAN::Meta; + +meta_yaml_ok(); diff --git a/xt/author/eol.t b/xt/author/eol.t new file mode 100644 index 0000000..5124f54 --- /dev/null +++ b/xt/author/eol.t @@ -0,0 +1,93 @@ +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::EOL 0.19 + +use Test::More 0.88; +use Test::EOL; + +my @files = ( + 'lib/File/KDBX.pm', + 'lib/File/KDBX/Cipher.pm', + 'lib/File/KDBX/Cipher/CBC.pm', + 'lib/File/KDBX/Cipher/Stream.pm', + 'lib/File/KDBX/Constants.pm', + 'lib/File/KDBX/Dumper.pm', + 'lib/File/KDBX/Dumper/KDB.pm', + 'lib/File/KDBX/Dumper/Raw.pm', + 'lib/File/KDBX/Dumper/V3.pm', + 'lib/File/KDBX/Dumper/V4.pm', + 'lib/File/KDBX/Dumper/XML.pm', + 'lib/File/KDBX/Entry.pm', + 'lib/File/KDBX/Error.pm', + 'lib/File/KDBX/Group.pm', + 'lib/File/KDBX/IO.pm', + 'lib/File/KDBX/IO/Crypt.pm', + 'lib/File/KDBX/IO/HashBlock.pm', + 'lib/File/KDBX/IO/HmacBlock.pm', + 'lib/File/KDBX/Iterator.pm', + 'lib/File/KDBX/KDF.pm', + 'lib/File/KDBX/KDF/AES.pm', + 'lib/File/KDBX/KDF/Argon2.pm', + 'lib/File/KDBX/Key.pm', + 'lib/File/KDBX/Key/ChallengeResponse.pm', + 'lib/File/KDBX/Key/Composite.pm', + 'lib/File/KDBX/Key/File.pm', + 'lib/File/KDBX/Key/Password.pm', + 'lib/File/KDBX/Key/YubiKey.pm', + 'lib/File/KDBX/Loader.pm', + 'lib/File/KDBX/Loader/KDB.pm', + 'lib/File/KDBX/Loader/Raw.pm', + 'lib/File/KDBX/Loader/V3.pm', + 'lib/File/KDBX/Loader/V4.pm', + 'lib/File/KDBX/Loader/XML.pm', + 'lib/File/KDBX/Object.pm', + 'lib/File/KDBX/Safe.pm', + 'lib/File/KDBX/Transaction.pm', + 'lib/File/KDBX/Util.pm', + 't/00-compile.t', + 't/00-report-prereqs.dd', + 't/00-report-prereqs.t', + 't/crypt.t', + 't/database.t', + 't/entry.t', + 't/erase.t', + 't/error.t', + 't/files/bin/ykchalresp', + 't/files/bin/ykinfo', + 't/group.t', + 't/hash-block.t', + 't/hmac-block.t', + 't/iterator.t', + 't/kdb.t', + 't/kdbx2.t', + 't/kdbx3.t', + 't/kdbx4.t', + 't/kdf-aes-pp.t', + 't/kdf.t', + 't/keys.t', + 't/lib/TestCommon.pm', + 't/memory-protection.t', + 't/object.t', + 't/otp.t', + 't/placeholders.t', + 't/query.t', + 't/references.t', + 't/safe.t', + 't/util.t', + 't/yubikey.t', + 'xt/author/clean-namespaces.t', + 'xt/author/critic.t', + 'xt/author/distmeta.t', + 'xt/author/eol.t', + 'xt/author/minimum-version.t', + 'xt/author/no-tabs.t', + 'xt/author/pod-coverage.t', + 'xt/author/pod-no404s.t', + 'xt/author/pod-syntax.t', + 'xt/author/portability.t', + 'xt/release/cpan-changes.t' +); + +eol_unix_ok($_, { trailing_whitespace => 1 }) foreach @files; +done_testing; diff --git a/xt/author/minimum-version.t b/xt/author/minimum-version.t new file mode 100644 index 0000000..277e084 --- /dev/null +++ b/xt/author/minimum-version.t @@ -0,0 +1,6 @@ +use strict; +use warnings; + +use Test::More; +use Test::MinimumVersion; +all_minimum_version_ok( qq{5.10.1} ); diff --git a/xt/author/no-tabs.t b/xt/author/no-tabs.t new file mode 100644 index 0000000..7f02347 --- /dev/null +++ b/xt/author/no-tabs.t @@ -0,0 +1,93 @@ +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::NoTabs 0.15 + +use Test::More 0.88; +use Test::NoTabs; + +my @files = ( + 'lib/File/KDBX.pm', + 'lib/File/KDBX/Cipher.pm', + 'lib/File/KDBX/Cipher/CBC.pm', + 'lib/File/KDBX/Cipher/Stream.pm', + 'lib/File/KDBX/Constants.pm', + 'lib/File/KDBX/Dumper.pm', + 'lib/File/KDBX/Dumper/KDB.pm', + 'lib/File/KDBX/Dumper/Raw.pm', + 'lib/File/KDBX/Dumper/V3.pm', + 'lib/File/KDBX/Dumper/V4.pm', + 'lib/File/KDBX/Dumper/XML.pm', + 'lib/File/KDBX/Entry.pm', + 'lib/File/KDBX/Error.pm', + 'lib/File/KDBX/Group.pm', + 'lib/File/KDBX/IO.pm', + 'lib/File/KDBX/IO/Crypt.pm', + 'lib/File/KDBX/IO/HashBlock.pm', + 'lib/File/KDBX/IO/HmacBlock.pm', + 'lib/File/KDBX/Iterator.pm', + 'lib/File/KDBX/KDF.pm', + 'lib/File/KDBX/KDF/AES.pm', + 'lib/File/KDBX/KDF/Argon2.pm', + 'lib/File/KDBX/Key.pm', + 'lib/File/KDBX/Key/ChallengeResponse.pm', + 'lib/File/KDBX/Key/Composite.pm', + 'lib/File/KDBX/Key/File.pm', + 'lib/File/KDBX/Key/Password.pm', + 'lib/File/KDBX/Key/YubiKey.pm', + 'lib/File/KDBX/Loader.pm', + 'lib/File/KDBX/Loader/KDB.pm', + 'lib/File/KDBX/Loader/Raw.pm', + 'lib/File/KDBX/Loader/V3.pm', + 'lib/File/KDBX/Loader/V4.pm', + 'lib/File/KDBX/Loader/XML.pm', + 'lib/File/KDBX/Object.pm', + 'lib/File/KDBX/Safe.pm', + 'lib/File/KDBX/Transaction.pm', + 'lib/File/KDBX/Util.pm', + 't/00-compile.t', + 't/00-report-prereqs.dd', + 't/00-report-prereqs.t', + 't/crypt.t', + 't/database.t', + 't/entry.t', + 't/erase.t', + 't/error.t', + 't/files/bin/ykchalresp', + 't/files/bin/ykinfo', + 't/group.t', + 't/hash-block.t', + 't/hmac-block.t', + 't/iterator.t', + 't/kdb.t', + 't/kdbx2.t', + 't/kdbx3.t', + 't/kdbx4.t', + 't/kdf-aes-pp.t', + 't/kdf.t', + 't/keys.t', + 't/lib/TestCommon.pm', + 't/memory-protection.t', + 't/object.t', + 't/otp.t', + 't/placeholders.t', + 't/query.t', + 't/references.t', + 't/safe.t', + 't/util.t', + 't/yubikey.t', + 'xt/author/clean-namespaces.t', + 'xt/author/critic.t', + 'xt/author/distmeta.t', + 'xt/author/eol.t', + 'xt/author/minimum-version.t', + 'xt/author/no-tabs.t', + 'xt/author/pod-coverage.t', + 'xt/author/pod-no404s.t', + 'xt/author/pod-syntax.t', + 'xt/author/portability.t', + 'xt/release/cpan-changes.t' +); + +notabs_ok($_) foreach @files; +done_testing; diff --git a/xt/author/pod-coverage.t b/xt/author/pod-coverage.t new file mode 100644 index 0000000..66b3b64 --- /dev/null +++ b/xt/author/pod-coverage.t @@ -0,0 +1,7 @@ +#!perl +# This file was automatically generated by Dist::Zilla::Plugin::PodCoverageTests. + +use Test::Pod::Coverage 1.08; +use Pod::Coverage::TrustPod; + +all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' }); diff --git a/xt/author/pod-no404s.t b/xt/author/pod-no404s.t new file mode 100644 index 0000000..eb9760c --- /dev/null +++ b/xt/author/pod-no404s.t @@ -0,0 +1,21 @@ +#!perl + +use strict; +use warnings; +use Test::More; + +foreach my $env_skip ( qw( + SKIP_POD_NO404S + AUTOMATED_TESTING +) ){ + plan skip_all => "\$ENV{$env_skip} is set, skipping" + if $ENV{$env_skip}; +} + +eval "use Test::Pod::No404s"; +if ( $@ ) { + plan skip_all => 'Test::Pod::No404s required for testing POD'; +} +else { + all_pod_files_ok(); +} diff --git a/xt/author/pod-syntax.t b/xt/author/pod-syntax.t new file mode 100644 index 0000000..e563e5d --- /dev/null +++ b/xt/author/pod-syntax.t @@ -0,0 +1,7 @@ +#!perl +# 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(); diff --git a/xt/author/portability.t b/xt/author/portability.t new file mode 100644 index 0000000..c531252 --- /dev/null +++ b/xt/author/portability.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use Test::More; + +eval 'use Test::Portability::Files'; +plan skip_all => 'Test::Portability::Files required for testing portability' + if $@; + +run_tests(); diff --git a/xt/release/cpan-changes.t b/xt/release/cpan-changes.t new file mode 100644 index 0000000..286005a --- /dev/null +++ b/xt/release/cpan-changes.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::CPAN::Changes 0.012 + +use Test::More 0.96 tests => 1; +use Test::CPAN::Changes; +subtest 'changes_ok' => sub { + changes_file_ok('Changes'); +}; -- 2.45.2