From: Charles McGarvey Date: Sun, 1 May 2022 03:15:10 +0000 (-0600) Subject: Version 0.800 X-Git-Url: https://git.dogcows.com/gitweb?a=commitdiff_plain;h=03bcac18fb7e0e84879f5f66fc89a3e5adfb76d6;p=chaz%2Fp5-File-KDBX Version 0.800 --- 03bcac18fb7e0e84879f5f66fc89a3e5adfb76d6 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 0000000..6c4c439 Binary files /dev/null and b/t/files/BrokenHeaderHash.kdbx differ diff --git a/t/files/CP-1252.kdb b/t/files/CP-1252.kdb new file mode 100644 index 0000000..707bc45 Binary files /dev/null and b/t/files/CP-1252.kdb differ diff --git a/t/files/CompositeKey.kdb b/t/files/CompositeKey.kdb new file mode 100644 index 0000000..70060d8 Binary files /dev/null and b/t/files/CompositeKey.kdb differ diff --git a/t/files/Compressed.kdbx b/t/files/Compressed.kdbx new file mode 100644 index 0000000..1f8ec2d Binary files /dev/null and b/t/files/Compressed.kdbx differ diff --git a/t/files/FileKeyBinary.kdb b/t/files/FileKeyBinary.kdb new file mode 100644 index 0000000..0ce9f58 Binary files /dev/null and b/t/files/FileKeyBinary.kdb differ diff --git a/t/files/FileKeyBinary.kdbx b/t/files/FileKeyBinary.kdbx new file mode 100644 index 0000000..fb9493f Binary files /dev/null and b/t/files/FileKeyBinary.kdbx differ 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 0000000..8ef7347 Binary files /dev/null and b/t/files/FileKeyHashed.kdb differ diff --git a/t/files/FileKeyHashed.kdbx b/t/files/FileKeyHashed.kdbx new file mode 100644 index 0000000..dd60ddc Binary files /dev/null and b/t/files/FileKeyHashed.kdbx differ diff --git a/t/files/FileKeyHashed.key b/t/files/FileKeyHashed.key new file mode 100644 index 0000000..33f4a9f Binary files /dev/null and b/t/files/FileKeyHashed.key differ diff --git a/t/files/FileKeyHex.kdb b/t/files/FileKeyHex.kdb new file mode 100644 index 0000000..ed872c5 Binary files /dev/null and b/t/files/FileKeyHex.kdb differ diff --git a/t/files/FileKeyHex.kdbx b/t/files/FileKeyHex.kdbx new file mode 100644 index 0000000..33f1fb1 Binary files /dev/null and b/t/files/FileKeyHex.kdbx differ 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 0000000..c3b26cd Binary files /dev/null and b/t/files/Format200.kdbx differ diff --git a/t/files/Format300.kdbx b/t/files/Format300.kdbx new file mode 100644 index 0000000..dc67f35 Binary files /dev/null and b/t/files/Format300.kdbx differ diff --git a/t/files/Format400.kdbx b/t/files/Format400.kdbx new file mode 100644 index 0000000..1a87750 Binary files /dev/null and b/t/files/Format400.kdbx differ diff --git a/t/files/MemoryProtection.kdbx b/t/files/MemoryProtection.kdbx new file mode 100644 index 0000000..6510cea Binary files /dev/null and b/t/files/MemoryProtection.kdbx differ diff --git a/t/files/NonAscii.kdbx b/t/files/NonAscii.kdbx new file mode 100644 index 0000000..06aa5bf Binary files /dev/null and b/t/files/NonAscii.kdbx differ diff --git a/t/files/ProtectedStrings.kdbx b/t/files/ProtectedStrings.kdbx new file mode 100644 index 0000000..bb50c03 Binary files /dev/null and b/t/files/ProtectedStrings.kdbx differ diff --git a/t/files/Twofish.kdb b/t/files/Twofish.kdb new file mode 100644 index 0000000..eb4ae6d Binary files /dev/null and b/t/files/Twofish.kdb differ diff --git a/t/files/basic.kdb b/t/files/basic.kdb new file mode 100644 index 0000000..16968ba Binary files /dev/null and b/t/files/basic.kdb differ 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'); +};